﻿unit u1cAgentServer;

interface

uses System.Classes, System.SyncObjs, System.Contnrs, System.Generics.Collections,
  u1CDataCollection, Data.DBXJSON, System.SysUtils, Winapi.Windows, Datasnap.DSTCPServerTransport,
  Datasnap.DSServer, Datasnap.DSCommonServer, Datasnap.DSAuth, IPPeerServer, u1cAgentTypes,
  u1cAgentClient, OmniXML, Vcl.SvcMgr, Datasnap.DSHTTP, Winapi.Messages, Vcl.Forms, uTasks,
  Vcl.OleServer, Data.SqlExpr, u1cAgentServerConst, WebModuleUnit, System.JSON;


type


  T1cGuard = class;
  TCustom1CAction = class;
  TProviderWorkThread = class;
  TCustomProviderList = class;
  T1CAppServer = class;
  TCustomProvider = class;
  TCommandResultSaver = class;


  TProviderEventData = (pdReloadInfo, pdAdd, pdDelete, pdConnected, pdDisconnected, pdPaused,
    pdResumed, pdLocked, pdUnlocked, pdReloadAll);
  TProviderEvent = procedure(Sender: TCustomProvider; Event: TProviderEventData) of object;
  TProviderListEvent = procedure(Sender: TCustomProviderList; Provider: TCustomProvider; Event: TProviderEventData) of object;


  TAutoCloseProviderInfo = class
  type
    TInactiveTimeType = (ms, seconds, minuts, hours, days);
    TCloseOnWeekDayTime = array[0..6] of TDateTime;
    TInactiveTiks = record
      Tiks: int64;
      TimeType: TInactiveTimeType;
      constructor Create(ATime: int64; ATimeType: TInactiveTimeType = ms);
      function IsSame(Value: TInactiveTiks): boolean;
      function IsLess(Value: TInactiveTiks): boolean;
      function TypeToStr(): string;
      procedure TypeFromStr(const AType: string);
    end;
  class var
    MinInactiveTimeInterval: TInactiveTiks;
    FAutoCloseInfoList: TObjectList<TAutoCloseProviderInfo>;
  private
    FInactiveTiks: TInactiveTiks;
    FCloseOnTime: TDateTime;
    FCloseOnWeekDayTime: TCloseOnWeekDayTime;
    FCloseOnWeekDayTimeEnable: boolean;
    function GetIsEmpty: boolean;

    procedure CheckMinInterval();
    procedure SetInactiveTiks(const Value: TInactiveTiks);
    function GetCloseOnWeekDayTime(DayOfWeek: byte): TDateTime;
    procedure SetCloseOnWeekDayTime(DayOfWeek: byte; const Value: TDateTime);
    function GetIsWeekTimeEmpty: boolean;
  public
    constructor Create();
    destructor Destroy; override;
    procedure Clear();
    procedure LoadFromXML(const ANode: IXMLNode);
    procedure SaveToXML(const ANode: IXMLNode);

    // время простоя
    property InactiveTiks: TInactiveTiks read FInactiveTiks write SetInactiveTiks;
    // астрономическое время без учета дней недели
    property CloseOnTime: TDateTime read FCloseOnTime write FCloseOnTime;
    // астрономическое время по дням недели
    property CloseOnWeekDayTimeEnable: boolean read FCloseOnWeekDayTimeEnable write FCloseOnWeekDayTimeEnable;
    property CloseOnWeekDayTime[DayOfWeek: byte]: TDateTime read GetCloseOnWeekDayTime write SetCloseOnWeekDayTime;
    // True если нет действительных установок
    property IsEmpty: boolean read GetIsEmpty;
    // True если нет настройки времени по дням недели
    property IsWeekTimeEmpty: boolean read GetIsWeekTimeEmpty;
  end;


  TCustomProvider = class
  strict private
    FSetActionLock: TCriticalSection;
    FCurrentAction: TCustom1CAction;
  private
    procedure SetDataBaseAlias(const Value: TDBAlias);
    procedure SetPaused(const Value: boolean);
    procedure SetProviderType(const Value: T1cProviderType);
  protected
    FOwner: TCustomProviderList;
    FProviderType: T1cProviderType;
    FDataBaseAlias: TDBAlias;
    FPaused: boolean;
    FOnChange: TProviderEvent;
    FAutoCloseInfo: TAutoCloseProviderInfo;

    function GetConnected: boolean; virtual; abstract;
    procedure SetConnected(const Value: boolean);
    function GetActivated: boolean; virtual; abstract;
    function GetLocked: boolean; virtual; abstract;
    procedure DoEvent(Event: TProviderEventData); virtual;

    procedure SetCurrentAction(ACmd: TCustom1CAction);
  public
    constructor Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType; const ADataBaseAlias: TDBAlias); virtual;
    destructor Destroy; override;

    // сохранение/восставноление данных провайдера в файле настройки
    procedure LoadFromXML(const ANode: IXMLNode); virtual;
    procedure SaveToXML(const ANode: IXMLNode); virtual;

    function Connect: boolean; virtual; abstract;
    procedure Disconnect; virtual; abstract;

    procedure Lock(); virtual; abstract;
    procedure UnLock(); virtual; abstract;

    function CommandExecuteStatus(CommandId: T1CActionID): TCommandExecuteStatus; virtual;

    // Уникальное имя базы дынных для идентификации в системе
    property DataBaseAlias: TDBAlias read FDataBaseAlias write SetDataBaseAlias;
    property ProviderType: T1cProviderType read FProviderType write SetProviderType;
    property Connected: boolean read GetConnected write SetConnected;
    property Activated: boolean read GetActivated; // отличается от Connected тем, что не определяет реальную доступность соединения. True означает лиш факт того, что для этого соединение использовалось
    property Paused: boolean read FPaused write SetPaused; // флаг приостановки и отклонения клиентских операций
    property IsLocked: boolean read GetLocked;  // аккупированы критические секции
    property AutoCloseInfo: TAutoCloseProviderInfo read FAutoCloseInfo;  // информация для авто-закрытия источника

    property OnChange: TProviderEvent read FOnChange write FOnChange;
  end;


  TLocalProvider = class(TCustomProvider)
  strict private
    FConfDataBase: string;
    FConfPassword: string;
    FConfUserName: string;
    FConfIsServerMode: boolean;
    FConfSrvName: string;
    FSharedVarName: string;
    FApplicationPID: DWORD;
  private
    FLockRef: integer;
    procedure Set1CApplicationPID(APID: DWORD);
    procedure SetConfDataBase(const Value: string);
    procedure SetConfSrvName(const Value: string);
    procedure SetConfUserName(const Value: string);
    procedure SetSharedVarName(const Value: string);
  protected
    FProviderWorkThread: TProviderWorkThread;
    F1CRef: IDispatch;
    FCmdIncomeLock: TCriticalSection;   // серилизация обработки анализа и постановки команды в очередь или синхронное ее выполнение
    FSyncCmdLock: TCriticalSection;     // серилизация обработки команды в контексте 1С

    function CheckConnection: boolean; virtual; abstract;
    function GetConnected: boolean; override;
    function GetActivated: boolean; override;
    function GetLocked: boolean; override;
    function RefTo: OleVariant;
  public
    constructor Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType; const ADataBaseAlias: string); override;
    destructor Destroy; override;

    procedure SaveToXML(const ANode: IXMLNode); override;
    procedure LoadFromXML(const ANode: IXMLNode); override;

    procedure ExecuteBatch(Code: TStringBuilder; IsCodeObjectOwner: boolean = False); overload; virtual;
    procedure ExecuteBatch(const Code: string); overload; virtual; abstract;
    function EvalExpr(const Code: string): OleVariant; virtual; abstract;

    procedure Disconnect; override;

    function Exec1CAction(ACmd: TCustom1CAction): integer; virtual;
    procedure Exec1CActionSync(ACmd: TCustom1CAction); virtual;
    function CommandExecuteStatus(CommandId: T1CActionID): TCommandExecuteStatus; override;

    // последовательный доступ к переменной F1CRef. Вызывать парно Acquire1CRef - Return1CRef
    function Acquire1CRef(const MethodName: string = ''): OleVariant; virtual;
    procedure Realize1CRef(const MethodName: string = ''); virtual;

    procedure Lock(); override;
    procedure UnLock(); override;
    procedure SyncLock();
    procedure SyncUnlock();

    // Указывает, что 1c запускается на сервере. Для 77 - sql-сервер, для 8х - сервере приложения
    property ConfIsServerMode: boolean read FConfIsServerMode write FConfIsServerMode;
    // Для файловой версия - путь к папке БД, для серверно - имя БД на сервере
    property ConfDataBase: string read FConfDataBase write SetConfDataBase;
    // Имя[:Порт] сервера расположения БД (режим  IsServerMode = true)
    property ConfSrvName: string read FConfSrvName write SetConfSrvName;
    // Имя пользователя и пароль. Для 8х для пользователя должно быть право на «Внешнее соединение».
    property ConfUserName: string read FConfUserName write SetConfUserName;
    property ConfPassword: string read FConfPassword write FConfPassword;
    // Имя переменной через которую осуществляется обмен данными с 1С. Переменная должна быть помечена как "Экспорт"
    property SharedVarName: string read FSharedVarName write SetSharedVarName;  // имя переменной 1с доступной для скрипта

    property ApplicationPID: DWORD read FApplicationPID write Set1CApplicationPID;
  end;

  TProviderWorkThread = class(TThread)
  strict private
    FEvent: TEvent;
    FCS: TCriticalSection;
    FQueue: TQueue<TCustom1CAction>;
    FOwner: TLocalProvider;
  public
    constructor Create(Owner: TLocalProvider);
    destructor Destroy; override;

    procedure Execute(); override;
    procedure Terminate;

    procedure Clear();
    function Add(ACmd: TCustom1CAction): integer;
    function CommandExist(ACommandId: T1CActionID): boolean;
  end;

  T1C77Provider = class(TLocalProvider)
  const
    DEF_APPKEY = 'V77.APPLICATION';
    DRF_RTM = 'TRADE';
  private
    FAppKey: string;
    FAppRtm: string;
    procedure SetAppKey(const Value: string);
    procedure SetAppRtm(const Value: string);
  strict private
    procedure TryConnect(const RunStr: string; AutoClose: boolean = false);
  protected
    function CheckConnection: boolean; override;
  public
    constructor Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType; const ADataBaseAlias: string); override;
    procedure SaveToXML(const ANode: IXMLNode); override;
    procedure LoadFromXML(const ANode: IXMLNode); override;


    function Connect: boolean; override;
    function EvalExpr(const Code: string): OleVariant; override;
    procedure ExecuteBatch(const Code: string); override;

    property AppKey: string read FAppKey write SetAppKey;
    property AppRtm: string read FAppRtm write SetAppRtm;
  end;

  T1C8Provider = class(TLocalProvider)
  strict private
    F1CConnector: TOleServer;
    procedure TryConnect(const RunStr: string; AutoClose: boolean = false);
    function GetInstallInfo(LIBID: TGUID; AHiVer, ALowVer: integer): string;
  protected
    function CheckConnection: boolean; override;
  public
    constructor Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType; const ADataBaseAlias: string); override;

    procedure Disconnect; override;
    function Connect: boolean; override;

    function LoadModule(const AModuleName: string): OleVAriant;
  end;

  TNetProvider = class(TCustomProvider)
  private
    FClient: T1CAppClient;
    FRemoteDataAlias: TDBAlias;
    FRemoteDataTypeInfo: T1cProviderType;
  protected
    function GetConnected: boolean; override;
    function GetActivated: boolean; override;
    function GetLocked: boolean; override;
  public
    constructor Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType; const ADataBaseAlias: TDBAlias); override;
    destructor Destroy; override;

    function Connect: boolean; override;
    procedure Disconnect; override;

    procedure SaveToXML(const ANode: IXMLNode); override;
    procedure LoadFromXML(const ANode: IXMLNode); override;

    procedure Lock(); override;
    procedure UnLock(); override;

    property Client: T1CAppClient read FClient;
    property RemoteDataAlias: TDBAlias read FRemoteDataAlias write FRemoteDataAlias;
    property RemoteDataTypeInfo: T1cProviderType read FRemoteDataTypeInfo write FRemoteDataTypeInfo; // проверяется лишь при специальном запросе
  end;


  TSupportedProviderArrRec = TPair<TDBAlias, TCustomProvider>;
  TSupportedProvidersArr = TArray<TSupportedProviderArrRec>;

  TCustomProviderList = class(TDictionary<TDBAlias, TCustomProvider>)
  private
    FOnEvent: TProviderListEvent;
    procedure SetOnEvent(const Value: TProviderListEvent);
  protected
    FCSList: TCriticalSection;
    FGuard: T1cGuard;

    procedure DoProviderEvent(Sender: TCustomProvider; Event: TProviderEventData);
    function GetAliasIdentificator(const DataBaseAlias: TDBAlias): TDBAlias;
    function CreateProvider(ProviderType: T1cProviderType; const DataBaseAlias: TDBAlias): TCustomProvider; virtual; abstract;
    procedure DoEvent(Event: TProviderEventData; Provider: TCustomProvider);
  public
    constructor Create(AGuard: T1cGuard); virtual;
    destructor Destroy; override;

    function Add(ProviderType: T1cProviderType; const DataBaseAlias: TDBAlias): TCustomProvider;
    procedure Update(Provider: TCustomProvider; const Alias: TDBAlias);
    function Find(const DataBaseAlias: TDBAlias): TCustomProvider;
    procedure Clear(); virtual;  // потоково не безопасный метод
    function Exists(AItem: TCustomProvider): boolean;
    procedure Delete(AItem: TCustomProvider); virtual;
    procedure FillArray(var Arr: TSupportedProvidersArr; AClearBefor: boolean = True);
    function CommandExecuteStatus(const ActionID: T1CActionID): TCommandExecuteStatus;

    procedure Save(ProvidersNode: IXMLNode); overload;
    procedure Load(ProvidersNode: IXMLNode); overload;

    property Guard: T1cGuard read FGuard;

    property OnEvent: TProviderListEvent read FOnEvent write SetOnEvent;
  end;


  TLocalProviderList = class(TCustomProviderList)
  protected
    function CreateProvider(ProviderType: T1cProviderType; const DataBaseAlias: TDBAlias): TCustomProvider; override;
  public
    function Find(const DataBaseAlias: TDBAlias): TLocalProvider; overload;
    function Find(PID: DWORD): TLocalProvider; overload;
    function Find(AProviderType: T1cProviderType; PID: DWORD): TLocalProvider; overload;

    procedure Delete(AItem: TCustomProvider); override;
  end;

  TNetProviderList = class(TCustomProviderList)
  protected
    function CreateProvider(ProviderType: T1cProviderType; const DataBaseAlias: TDBAlias): TCustomProvider; override;
  public
    function Find(const DataBaseAlias: TDBAlias): TNetProvider;
  end;

  TCustom1CAction = class
  strict private
    FResultStatus: T1CActionResult;
  protected
    FProvider: TLocalProvider;
    FSourceCode: TStringBuilder;
    FStepStatus: T1CActionStepStatus;
    FClientInfo: T1CActionClientInfo;
    FDBAliace: TDBAlias;
    FServer: T1CAppServer;

    procedure SendCallback(); virtual;
    constructor Create(AServer: T1CAppServer; const ADBAliase: TDBAlias); virtual;
  public
    constructor CreateSync(AServer: T1CAppServer; const ADBAliase: TDBAlias;
      const AClientID, ACommandID: string); virtual;
    constructor CreateAsync(AServer: T1CAppServer; const ADBAliase: TDBAlias;
      const AClientID, ACommandID: string); virtual;
    destructor Destroy(); override;

    // вызывается для проверки установленных параметров команды в серрвеном методе
    procedure CheckParams; virtual;
    // вызывается один раз для подготовки операции перед выполнением метода Execute в контексте вызывающего потока
    procedure Prepare(); virtual;
    // вызывается для выполнения действий в 1С
    procedure Execute(A1CRef: OleVariant); virtual; abstract;
    // выполняет / ставит в очередь выполнения провайдера комманду
    function BeginExec(BuildWebAnswer: boolean = False): TJSONValue; virtual;
    // вызывается при завершении операции вручную в Execute или автоматически при возникновении
    // исключения на этапах выполнения команды
    procedure EndExec(AResultStatus: T1CActionResult); virtual;

    property DBAliace: TDBAlias read FDBAliace;
    property Server: T1CAppServer read FServer;
    property Provider: TLocalProvider read FProvider;
    property StepStatus: T1CActionStepStatus read FStepStatus;
    property ClientInfo: T1CActionClientInfo read FClientInfo;
    property ResultStatus: T1CActionResult read FResultStatus;
  end;


 T1cGuard = class(TThread)
  private
    FCS: TCriticalSection;
    FOpenQuery: TList<TLocalProvider>;
    FEvent: TEvent;
    FExistsPIDList: TDictionary<DWORD, DWORD>;
    FInnerDLGFounded: array[ord(Low(T1cProviderType))..ord(High(T1cProviderType))] of string;
    FServer: T1CAppServer;

    procedure EmulateKey(Wnd: HWND; VKey: Integer);
    function IsModal(Wnd: hWnd): boolean;
    procedure BuildExistsPIDList;
    function FindProviderInOpenQuery(AProvType: T1cProviderType): TLocalProvider;

    procedure Do1CMonitoring();
    function GetInnerDLGFounded(Index: T1cProviderType): string;
  public
    constructor Create(AServer: T1CAppServer);
    destructor Destroy; override;
    procedure Execute(); override;
    procedure Terminate;

    function StartConnectionMonitoring(Provider: TLocalProvider): boolean;    // вызывается до начала процесса соединения
    procedure StopConnectionMonitoring(Provider: TLocalProvider);  // вызывается после окончания процесса соединия

    property InnerDLGFounded[Index: T1cProviderType]: string read GetInnerDLGFounded; // true, если были обноаружены диалоговые окна в процессе 1с
  end;


  TServerRunMode = (srmNone, srmAppAutorun, srmService);
  TServerRunModeChangeEvent = procedure(Sender: T1CAppServer; RunMode: TServerRunMode) of object;

  {Изменение свойств настройки сервера потоково-небезопасно!}
  T1CAppServer = class
  strict private
    FGuard: T1cGuard;
    dsServer: TDSServer;
    dsTCPServerTransport: TDSTCPServerTransport;
    dsHTTPServerTransport: TDSHTTPService;
    dsWebModule: TwvWebModule;
    dsAuthenticationManager: TDSAuthenticationManager;
    dsServerClass: TDSServerClass;

    FConPassword: string;

    FProviders: TLocalProviderList;
    FNetProviders: TNetProviderList;

    procedure dsServerClassGetClass(DSServerClass: TDSServerClass;
      var PersistentClass: TPersistentClass);
    procedure dsAuthenticationManagerUserAuthenticate(Sender: TObject;
      const Protocol, Context, User, Password: string; var valid: Boolean;
      UserRoles: TStrings);
  private
    FSettingsFile: string;
    FSharedFolder: string;
    FConEncryptTrafficKey: string;
    FConCompressTraffic: integer;
    FConEncryptRSA: boolean;
    FConRunServerMode: TServerRunMode;
    FSupportedInterface: TServerInterfaces;
    FMaxThread: integer;
    FLogEnabled: boolean;
    FLogDetailed: boolean;
    FLogMaxSize: integer;
    FLogDispatherFileName: string;
    FLogFileName: string;
    FLogFileViewerFileName: string;
    FOnRunModeChange: TServerRunModeChangeEvent;

    FTasks: TTaskList;
    FSqliteConnection: TSQLConnection;
    FCommandResultSaver: TCommandResultSaver;
    FRequestCommandResult: TDictionary<String, Byte>;
    FRequestCommandResultLock: TCriticalSection;

    function GetStarted: boolean;
    procedure DoConnect(DSConnectEventObject: TDSConnectEventObject);
    procedure DoDisconnect(DSConnectEventObject: TDSConnectEventObject);
    procedure DoServerError(DSErrorEventObject: TDSErrorEventObject);

    procedure SaveToXML(ANode: IXMLNode);
    procedure LoadLoadFromXML(ANode: IXMLNode);

    function GetSharedFolder: string;
    procedure SetSharedFolder(const Value: string);
    function GetIsSharedFolderPathEmpty: boolean;
    procedure SetConCompressTraffic(const Value: integer);
    procedure SetConEncryptTrafficKey(const Value: string);
    procedure SetConEncryptRSA(const Value: boolean);
    procedure SetConRunServerMode(const Value: TServerRunMode);

    procedure SetAppAutorun(ARun: boolean);
    procedure SetSupportedInterface(const Value: TServerInterfaces);
    function GetPort(Protocol: TServerInterfaceItem): integer;
    procedure SetPort(Protocol: TServerInterfaceItem; const Value: integer);
    procedure SetLogEnabled(const Value: boolean);
    procedure SetLogMaxSize(const Value: integer);
    procedure SetLogDetailed(const Value: boolean);
    function GetLogFileName: string;
    procedure SetDefaultLogParams();

    procedure InitSqliteConnection;
    procedure CreateTasksTable;
    procedure CreateCommandResultsTable;

    procedure OnClientRegisterEvent(Sender: TObject; const EventItem: TDSCallbackTunnelEventItem);
    procedure SendReceiptListToClient(Data: TObject; var RepeatInterval: Int64);
    procedure SendPingToClient(Data: TObject; var RepeatInterval: Int64);
    procedure SendCommandResultToClient(CommandResult: TCommandResult);

  public
    constructor Create();
    destructor Destroy; override;

    function NotifyCallback(ACmd: TCustom1CAction; Msg: TJSONValue): boolean; overload;  // Msg уничтожается
    function NotifyCallback(ACmd: TCustom1CAction; Msg: TJSONValue; var Response: TJSONValue): boolean; overload; // Msg уничтожается

    procedure Start();
    procedure Stop();

    procedure SaveSettings(const FileName: string = '');
    procedure LoadSettings(const FileName: string = '');

    function FindProvider(const Alias: TDBAlias): TCustomProvider;
    function ExistsProvider(AProvider: TCustomProvider): boolean;
    procedure DeleteProvider(AProvider: TCustomProvider);

    function CommandExecuteStatus(ACommandID: T1CActionID): TCommandExecuteStatus;
    procedure StoreResult(AResult: TCommandResult);
    function GetCommandResult(const CommandId: String; DiskLook: Boolean): TCommandResult;
    procedure RegisterRequestCommandResult(const CommandId: String);
    procedure FillCommandResultList(CommandIdList: TJSONArray; List: TCommandResultList);
    procedure RemoveCommandResultList(CommandIdList: TJSONArray);

    property Providers: TLocalProviderList read FProviders;
    property NetProviders: TNetProviderList read FNetProviders;

    property _dsServer: TDSServer read dsServer;
    property _dsAuthenticationManager: TDSAuthenticationManager read dsAuthenticationManager;

    property Tasks: TTaskList read FTasks;

    property Started: boolean read GetStarted;

    property Port[Protocol: TServerInterfaceItem]: integer read GetPort write SetPort;

    property LogEnabled: boolean read FLogEnabled write SetLogEnabled;
    property LogDetailed: boolean read FLogDetailed write SetLogDetailed;
    property LogMaxSize: integer read FLogMaxSize write SetLogMaxSize; // МБ. Рассчитывается примерно количеству сообщений
    property LogDispatherFileName: string read FLogDispatherFileName;
    property LogFileViewerFileName: string read FLogFileViewerFileName;
    property LogFileName: string read GetLogFileName; // имя файла лога. В FLogFileName- основание имении, LogFileName - полное имя файла
    // проверочный пароль уровня приложения для TDSAuthenticationManager
    property ConPassword: string read FConPassword write FConPassword;
    // задает ключ шифрования RC1. При изменении сервер остановится
    property ConEncryptTrafficKey: string read FConEncryptTrafficKey write SetConEncryptTrafficKey;
    // если задан FConEncryptTrafficKey, то включает несимметричное шифрование. При изменении сервер остановится
    property ConEncryptRSA: boolean read FConEncryptRSA write SetConEncryptRSA;
    // -1 не сжимать трафик. 1024 - сжимать трафик более чем 1кб. Другое число - сжимать весь трафик. При изменении сервер остановится
    property ConCompressTraffic: integer read FConCompressTraffic write SetConCompressTraffic;
    // запуска сервера согласно настройкам: 0 - приложение, 1 - "Автозагрузка", 2 - сервис
    property ConRunServerMode: TServerRunMode read FConRunServerMode write SetConRunServerMode;
    // поддерживаемые протоколы
    property SupportedInterface: TServerInterfaces read FSupportedInterface write SetSupportedInterface;


    // каталог "\\Репозиторий" внешних отчетов 1С
    property SharedFolder: string read GetSharedFolder write SetSharedFolder;
    // указывает на то, что каталог "репозитория" задан, а не сожержит путь "по-умолчанию", который генерирует сервер
    property IsSharedFolderPathEmpty: boolean read GetIsSharedFolderPathEmpty;

    // путь к файлу настройки сервера. Изменяется при вызове LoadSettings
    property SettingsFile: string read FSettingsFile write FSettingsFile;

    property OnRunModeChange: TServerRunModeChangeEvent read FOnRunModeChange write FOnRunModeChange;
  end;

  TCommandResultSaver = class
  private
    FSQLConnection: TSQLConnection;

    FResultLiveTime: Int64;               // время жизни результата вообще (и в памяти и на диске)
    FClearResultsInterval: Int64;         // периодичность удаления "старых" результатов
    FResultBufferLiveTime: Int64;         // время через которое удалять результаты из памяти, если в данный момент времени
                                          // результат не был сохранен на диск, то он будет сохранен
    FResultStoreToDiskTime: Int64;        // время, через которое сохранять результат на диск из памяти

    FBuffer: TObjectList<TCommandResult>;
    FBufferIndex: TDictionary<String, TCommandResult>;
    FBufferSyncCommands: TDictionary<String, TCommandResult>;

    procedure OnChangeBuffer(Sender: TObject; const Item: TCommandResult; Action: TCollectionNotification);

    procedure ClearOldResults;
    procedure StoreBuffer;
    function StoreToDisk(AResult: TCommandResult): Boolean;

    procedure ClearOldResultsEvent(Data: TObject; var RepeatInterval: Int64);
    procedure StoreToDiskEvent(AResult: TObject; var RepeatInterval: Int64);
    procedure RemoveFromBufferEvent(AResult: TObject; var RepeatInterval: Int64);

    procedure CancelEvents(AResult: TCommandResult);

  public
    property ResultLiveTime: Int64 read FResultLiveTime write FResultLiveTime;
    property ClearResultsInterval: Int64 read FClearResultsInterval write FClearResultsInterval;
    property ResultBufferLiveTime: Int64 read FResultBufferLiveTime write FResultBufferLiveTime;

    procedure StoreResult(AResult: TCommandResult);
    procedure FillReceiptList(const ClientId: String; List: TReceiptList);
    procedure FillResultList(CommandIdList: TJSONArray; List: TCommandResultList);
    procedure SetReceiptIsSent(List: TReceiptList);
    function GetResult(const CommandId: String; DiskLook: Boolean): TCommandResult;
    procedure RemoveResult(const CommandId: String);
    procedure RemoveResultList(CommandIdList: TJSONArray);

    constructor Create(ASQLConnection: TSQLConnection);
    destructor Destroy; override;
  end;

  TServerServiceContainer = class(TService)
  private
    FServer: T1CAppServer;
  protected
    procedure DoStart; override;
    function DoStop: Boolean; override;
  public
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
    destructor Destroy; override;
    function GetServiceController: TServiceController; override;
  end;


var
  gbServerServiceContainer: TServerServiceContainer = nil;


implementation

uses u1cAgentConst, System.Variants, ComObj, System.StrUtils, Datasnap.DSNames,
  TlHelp32, System.TypInfo, CodeSiteLogging, Winapi.ActiveX, uServerMethods, Data.DBXTransport,
  System.Win.Registry, pc1, CodeSiteGlobal, ShellApi, V81_TLB, V82_TLB, V80_TLB, Data.DBXCommon, System.DateUtils, uEventHandler,
  Data.DB, Datasnap.DBClient, Datasnap.DSClientRest, Datasnap.DSCommon, Web.WebReq;


procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  gbServerServiceContainer.Controller(CtrlCode);
end;


{ T1cAgentServer }

function T1CAppServer.GetCommandResult(const CommandId: String; DiskLook: Boolean): TCommandResult;
begin
  result:= FCommandResultSaver.GetResult(CommandId, DiskLook);
end;

function T1CAppServer.CommandExecuteStatus(ACommandID: T1CActionID): TCommandExecuteStatus;
begin
  result:= FProviders.CommandExecuteStatus(ACommandID);
  if result = cesNotExist then
    result:= FNetProviders.CommandExecuteStatus(ACommandID);
end;

constructor T1CAppServer.Create();
begin
  FSqliteConnection:= TSQLConnection.Create(nil);
  try
    InitSqliteConnection;
  except
    on E: Exception do begin
      FreeAndNil(FSqliteConnection);
      CodeSite.SendException(classname+'.Create', E);
    end;
  end;

  FRequestCommandResultLock:= TCriticalSection.Create;
  FRequestCommandResult:= TDictionary<String, Byte>.Create;
  FCommandResultSaver:= TCommandResultSaver.Create(FSqliteConnection);


  FGuard:= T1cGuard.Create(self);

  FSettingsFile:= IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)))+PROVIDER_LIST_XML_FILE_NAME;
  FConPassword:= CLIENT_DEFAULT_USER_PWD;

  dsServer:= TDSServer.Create(nil);
  dsServer.AutoStart:= False;
  dsServer.HideDSAdmin:= True;
  dsServer.OnConnect:= DoConnect;
  dsServer.OnDisconnect:= DoDisconnect;
  dsServer.OnError:= DoServerError;

  dsServerClass:= TDSServerClass.Create(nil);
  dsServerClass.LifeCycle:= TDSLifeCycle.Server;
  dsServerClass.Server:= dsServer;
  dsServerClass.OnGetClass:= dsServerClassGetClass;

  dsAuthenticationManager:= TDSAuthenticationManager.Create(nil) ;
  dsAuthenticationManager.OnUserAuthenticate:= dsAuthenticationManagerUserAuthenticate;

  FProviders:= TLocalProviderList.Create(FGuard);
  FNetProviders:= TNetProviderList.Create(FGuard);

  FSharedFolder:= EmptyStr;

  dsTCPServerTransport:= nil;
  dsHTTPServerTransport:= nil;
  dsWebModule:= nil;
  FSupportedInterface:= [];

  SetDefaultLogParams(); { TODO : Можно ли перенести вначало? }

  FTasks:= TTaskList.Create(self, FSqliteConnection);

  TDSCallbackTunnelManager.Instance.AddTunnelEvent(OnClientRegisterEvent);

  Start;
end;

procedure T1CAppServer.CreateCommandResultsTable;
var
  transaction: TDBXTransaction;
  query: TSQLQuery;
begin
  query:= TSQLQuery.Create(nil);
  try
    query.SQLConnection:= FSqliteConnection;
    transaction:=FSqliteConnection.BeginTransaction;
    try
      query.SQL.Text:='create table if not exists CommandResults('+
        'ClientId varchar(50), '+
        'ResultTime int64, '+
        'Started int64, '+
        'Finished int64, '+
        'CommandId varchar(50), '+
        'Result blob, '+
        'ErrorDescription varchar(100), '+
        'ReceiptIsSent bool)';
      query.ExecSQL;
      query.SQL.Text:='create index if not exists indCommandResults_ClientId on CommandResults(ClientId)';
      query.ExecSQL;
      query.SQL.Text:='create unique index if not exists indCommandResults_CommandId on CommandResults(CommandId)';
      query.ExecSQL;
      query.SQL.Text:='create index if not exists indCommandResults_ResultTime on CommandResults(ResultTime)';
      query.ExecSQL;
      query.SQL.Text:='create index if not exists indCommandResults_ReceiptIsSent on CommandResults(ReceiptIsSent)';
      query.ExecSQL;
      FSqliteConnection.CommitFreeAndNil(transaction);
    except
      FSqliteConnection.RollbackFreeAndNil(transaction);
      raise;
    end;
  finally
    query.Free;
  end;
end;

procedure T1CAppServer.CreateTasksTable;
var
  transaction: TDBXTransaction;
  query: TSQLQuery;
begin
  query:= TSQLQuery.Create(nil);
  try
    query.SQLConnection:= FSqliteConnection;
    transaction:=FSqliteConnection.BeginTransaction;
    try
      query.SQL.Text:='create table if not exists Tasks('+
        'GUID GUID, '+
        'Start int64, '+
        'Stop int64, '+
        'Status varchar(300))';
      query.ExecSQL;
      query.SQL.Text:='create index if not exists indTasks_GUID on Tasks(GUID)';
      query.ExecSQL;
      query.SQL.Text:='create index if not exists indTasks_Start on Tasks(Start)';
      query.ExecSQL;
      FSqliteConnection.CommitFreeAndNil(transaction);
    except
      FSqliteConnection.RollbackFreeAndNil(transaction);
      raise;
    end;
  finally
    query.Free;
  end;
end;

procedure T1CAppServer.DeleteProvider(AProvider: TCustomProvider);
var
  step: TStep;
begin
  step:=Tasks.StepUsedProvider(AProvider);
  if  step<>nil then
    raise Exception.CreateFmt(sSRV_47, [step.Owner.Name, step.Name]);

  if AProvider is TLocalProvider then
    FProviders.Delete( AProvider )
  else
    FNetProviders.Delete( AProvider );
end;

destructor T1CAppServer.Destroy;
begin
  TDSCallbackTunnelManager.Instance.RemoveTunnelEvent(OnClientRegisterEvent);
  TEventHandler.CancelGroupEvents(Self);

  FTasks.Free;

  FGuard.Terminate;
  FGuard.Free;
  dsServer.Free;
  dsServerClass.Free;
  dsAuthenticationManager.Free;

  if dsTCPServerTransport <> nil then
    dsTCPServerTransport.Free;
  if dsHTTPServerTransport <> nil then
    dsHTTPServerTransport.Free;
  if dsWebModule <> nil then begin
    dsWebModule.Free;
    Web.WebReq.FreeWebModules;
  end;

  FProviders.Free;
  FNetProviders.Free;
  LogEnabled:= False;

  FCommandResultSaver.Free;
  FRequestCommandResultLock.Free;
  FRequestCommandResult.Free;
  FSqliteConnection.Free;

  inherited;
end;

procedure T1CAppServer.DoConnect(DSConnectEventObject: TDSConnectEventObject);
begin
  CoUninitialize();
  CoInitializeEx(nil, COINIT_MULTITHREADED{COINIT_APARTMENTTHREADED});
//  CoInitialize(nil);
end;

procedure T1CAppServer.DoDisconnect(DSConnectEventObject: TDSConnectEventObject);
begin
  CoUninitialize();
end;

procedure T1CAppServer.DoServerError(DSErrorEventObject: TDSErrorEventObject);
begin
//  if DSErrorEventObject.Error = nil then
end;

procedure T1CAppServer.dsAuthenticationManagerUserAuthenticate(Sender: TObject; const Protocol, Context, User,
  Password: string; var valid: Boolean; UserRoles: TStrings);
begin
  // пароль передается в зашифрованном виде
  valid := {(User = CLIENT_DEFAULT_USER_NAME) and (}
    (FConPassword = EmptyStr) or ((FConPassword <> EmptyStr) and (Password = FConPassword))
  {)};
  if LogDetailed then
    { TODO : добавить IP }
    if valid then
      CodeSite.SendError(Format(sSRV_33, [trim(User)]))
    else
      CodeSite.SendError(Format(sSRV_32, [trim(User)]));
end;

procedure T1CAppServer.dsServerClassGetClass(DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
  uServerMethods.TGate1C.FServer:= self;
  PersistentClass := uServerMethods.TGate1C;
end;

function T1CAppServer.ExistsProvider(AProvider: TCustomProvider): boolean;
begin
  if AProvider is TNetProvider then
    result:= FNetProviders.Exists(AProvider)
  else
    result:= FProviders.Exists(AProvider);
end;

procedure T1CAppServer.FillCommandResultList(CommandIdList: TJSONArray;
  List: TCommandResultList);
begin
  FCommandResultSaver.FillResultList(CommandIdList, List);
end;

function T1CAppServer.FindProvider(const Alias: TDBAlias): TCustomProvider;
begin
  result:= FProviders.Find(Alias );
  if result = nil then
    result:= FNetProviders.Find(Alias);
end;

function T1CAppServer.GetIsSharedFolderPathEmpty: boolean;
begin
  result:= FSharedFolder = EmptyStr;
end;

function T1CAppServer.GetLogFileName: string;
begin
  result:= FLogFileName+'_1.csl';
end;

function T1CAppServer.GetPort(Protocol: TServerInterfaceItem): integer;
begin
  case Protocol of
    ssiTCP: begin
      if dsTCPServerTransport = nil then
        raise Exception.CreateFmt(sSRV_31, ['TCP']);
      result:= dsTCPServerTransport.Port;
    end;
    ssiHTTP: begin
      if dsHTTPServerTransport = nil then
        raise Exception.CreateFmt(sSRV_31, ['HTTP']);
      result:= dsHTTPServerTransport.HttpPort;
    end;
    ssiRest: begin
      if dsWebModule = nil then
        raise Exception.CreateFmt(sSRV_31, ['REST']);
      result:= dsWebModule.HTTPServer.DefaultPort;
    end
    else begin
      result:= 0;
      Assert(False, 'Не известный интерфейс');
    end;
  end;
end;

function T1CAppServer.GetSharedFolder: string;
begin
  if FSharedFolder = EmptyStr then
    Result:= IncludeTrailingPathDelimiter(ExtractFilePath( ParamStr(0) ))
  else
    Result := FSharedFolder;
end;

function T1CAppServer.GetStarted: boolean;
begin
  result:= dsServer.Started;
end;

procedure T1CAppServer.InitSqliteConnection;
begin
  FSqliteConnection.DriverName:='Sqlite';
  FSqliteConnection.Params.Values['DataBase']:=ChangeFileExt(ExtractFilePath(ParamStr(0))+ExtractFileName(ParamStr(0)), '.db');
  FSqliteConnection.Params.Values['FailIfMissing']:='False';
  FSqliteConnection.Params.Values['ColumnMetaDataSupported']:='False';
  FSqliteConnection.Open;
  CreateTasksTable;
  CreateCommandResultsTable;
end;

procedure T1CAppServer.LoadLoadFromXML(ANode: IXMLNode);
var
  strValue: string;
  chl, node: IXMLNode;
  wPort: Word;
begin

  if ANode.HasAttribute('Run') then begin
    strValue:= UpperCase(trim(ANode.Attributes['Run']));
    if strValue = 'USERAUTORUN' then
      FConRunServerMode:= TServerRunMode.srmAppAutorun
    else if strValue = 'ASSERVICE' then
      FConRunServerMode:= TServerRunMode.srmService
    else
      FConRunServerMode:= TServerRunMode.srmNone;
  end;

  if Assigned(FOnRunModeChange) then
    try
      FOnRunModeChange(self, FConRunServerMode)
    except
    end;


  chl:= ANode.FindNode('Log');
  if chl <> nil then begin
    LogEnabled:= chl.HasAttribute('Enable') and (AnsiUpperCase(chl.Attributes['Enable']) = 'TRUE');
    LogDetailed:= chl.HasAttribute('Detailed') and (AnsiUpperCase(chl.Attributes['Detailed']) = 'TRUE');
    if chl.HasAttribute('MaxSize') then
      LogMaxSize:= StrToIntDef(trim(chl.Attributes['MaxSize']), 1);
  end;


  chl:= ANode.FindNode('Interface');
  if chl <> nil then begin
    node:= chl.FindNode('TCP');
    if node <> nil then begin
      SupportedInterface:= SupportedInterface + [ssiTCP];
      if node.HasAttribute('Port') then begin
        wPort:= StrToIntDef(node.Attributes['Port'], SERVER_TCP_PORT);
        if dsTCPServerTransport.Port <> wPort then begin
          dsTCPServerTransport.Stop;
          dsTCPServerTransport.Port:= wPort;
          dsTCPServerTransport.Start;
        end;
      end else
        dsTCPServerTransport.Port:= SERVER_TCP_PORT;
    end else
      SupportedInterface:= SupportedInterface - [ssiTCP];

    node:= chl.FindNode('HTTP');
    if node <> nil then begin
      SupportedInterface:= SupportedInterface + [ssiHTTP];
      if node.HasAttribute('Port') then begin
        wPort:= StrToIntDef(node.Attributes['Port'], SERVER_HTTP_PORT);
        if dsHTTPServerTransport.HttpPort <> wPort then begin
          dsHTTPServerTransport.Stop;
          dsHTTPServerTransport.HttpPort:= wPort;
          dsHTTPServerTransport.Start;
        end;
      end else
        dsHTTPServerTransport.HttpPort:= SERVER_HTTP_PORT;
    end else
      SupportedInterface:= SupportedInterface - [ssiHTTP];

    node:= chl.FindNode('REST');
    if node <> nil then begin
      SupportedInterface:= SupportedInterface + [ssiRest];
      if node.HasAttribute('Port') then begin
        wPort:= StrToIntDef(node.Attributes['Port'], SERVER_HTTP_PORT);
        if dsWebModule.HTTPServer.DefaultPort <> wPort then begin
          dsWebModule.HTTPServer.Active:= False;
          dsWebModule.HTTPServer.DefaultPort:= wPort;
          dsWebModule.HTTPServer.Active:= True;
        end;
      end else
        dsWebModule.HTTPServer.DefaultPort:= SERVER_REST_PORT;
    end else
      SupportedInterface:= SupportedInterface - [ssiRest];

  end else begin
    SupportedInterface:= SupportedInterface - [ssiTCP];
    SupportedInterface:= SupportedInterface - [ssiHTTP];
    SupportedInterface:= SupportedInterface - [ssiRest];
  end;


  chl:= ANode.FindNode('ConPassword');
  if chl <> nil then
    FConPassword:= TPC1.DeCrypt(SERVER_CONFIG_CRYPT_KEY, chl.Text);

  chl:= ANode.FindNode('MaxThreads');
  if chl <> nil then begin
    FMaxThread:= StrToInt(chl.Text);
{    if FMaxThread < 1 then
      FMaxThread:= 1
    else if FMaxThread > 12 then
      FMaxThread:= 12;}

    if dsTCPServerTransport.MaxThreads <> FMaxThread then
      dsTCPServerTransport.MaxThreads:= FMaxThread;
  end;

  chl:= ANode.FindNode('SharedFolder');
  if chl <> nil then
    SharedFolder:= chl.Text;

  chl:= ANode.FindNode('CompressTraffic');
  if chl <> nil then
    if UpperCase(trim(chl.Text)) = 'TRUE' then
      ConCompressTraffic:= 0
    else if UpperCase(trim(chl.Text)) = 'FALSE' then
      ConCompressTraffic:= -1
    else
      ConCompressTraffic:= SERVER_COMPRESS_TRAFFIC_DEFAULT;


  chl:= ANode.FindNode('EncryptTrafficKey');
  if (chl <> nil) then
    ConEncryptTrafficKey:= TPC1.DeCrypt(SERVER_CONFIG_CRYPT_KEY, chl.Text)
  else
    ConEncryptTrafficKey:= EmptyStr;

end;

procedure T1CAppServer.LoadSettings(const FileName: string);
var
  xmldoc: IXMLDocument;
  xmlList: IXMLNode;
begin
  FProviders.Clear;
  FNetProviders.Clear;

  FTasks.Clear;

  if FileName <> EmptyStr then
    FSettingsFile:= FileName;

  try
    if (FSettingsFile = EmptyStr) then
      raise Exception.Create(sSRV_7);
    if not FileExists(FSettingsFile ) then
      raise Exception.CreateFmt(sSRV_6, [ FSettingsFile ]);

    xmldoc:= CreateXMLDoc;
    xmldoc.LoadFromFile(FSettingsFile);

    xmlList:= xmldoc.DocumentElement.FindNode('Server');
    if xmlList <> nil then
      LoadLoadFromXML(xmlList);

    xmlList:= xmldoc.DocumentElement.FindNode('LocalProviders');
    if xmlList <> nil then
      FProviders.Load(xmlList);

    xmlList:= xmldoc.DocumentElement.FindNode('NetProviders');
    if xmlList <> nil then
      FNetProviders.Load(xmlList);

    xmlList:= xmldoc.DocumentElement.FindNode('Tasks');
    if xmlList <> nil then
      FTasks.LoadFromXML(xmlList);

  except
    on E: Exception do begin
      CodeSite.SendError(classname+'.LoadSettings: "'+E.Message+'"');
    end;
  end;
end;

function T1CAppServer.NotifyCallback(ACmd: TCustom1CAction; Msg: TJSONValue; var Response: TJSONValue): boolean;
var
  answer_str: String;
begin
  try
    Msg.Owned:= False; // не трогать!!! так надо
    try
      result:= dsServer.NotifyCallback(
        ACmd.ClientInfo.ClientID,
        ACmd.ClientInfo.CallbackCommandName,
        Msg,
        Response,
        CLIENT_TIMEOUT
        );

        if Response <> nil then
          try
            answer_str:= Response.Value;
          except
            answer_str:= EmptyStr;
          end
        else
          answer_str:= EmptyStr;

      if answer_str <> CLIENT_RESPONSE_ON_CALLBACK then begin
        // Сохраняем результат для команды. Возможно клиент обратиться за ним позже
        StoreResult(TCommandResult.Create(ACmd.ClientInfo.ClientID, Now, ACmd.StepStatus.Started, ACmd.StepStatus.Finished, ACmd.ClientInfo.CommandID, Msg, ACmd.ResultStatus.Error));
        Msg:= nil;
        exit(False);
      end;
    finally
      Msg.Free;
    end;
  except
    on E: Exception do begin
      CodeSite.SendException(classname+'.NotifyCallback', E);
      result:= False;
    end;
  end;
end;

procedure T1CAppServer.OnClientRegisterEvent(Sender: TObject;
  const EventItem: TDSCallbackTunnelEventItem);
begin
  case EventItem.EventType of
    TDSCallbackTunnelEventType.CallbackAdded:
      if EventItem.CallbackId = SERVER_CALLBACK_SERVER_INFO then
        TEventHandler.AddEvent(Self, nil, TJSONString.Create(EventItem.TunnelId), SendReceiptListToClient, 0, True)
      else if EventItem.CallbackId = SERVER_CALLBACK_PING then
        TEventHandler.AddEvent(Self, nil, EventItem.Tunnel, SendPingToClient, SERVER_PING_INTERVAL);
    TDSCallbackTunnelEventType.TunnelClose:
      TEventHandler.CancelEvent(EventItem.Tunnel, SendPingToClient);
  end;
end;

procedure T1CAppServer.RegisterRequestCommandResult(const CommandId: String);
var
  command_result: TCommandResult;
begin
  FRequestCommandResultLock.Enter;
  try
    command_result:= FCommandResultSaver.GetResult(CommandId, False);
    try
      if command_result <> nil then begin
        SendCommandResultToClient(command_result);
        exit;
      end;
    finally
      command_result.Free;
    end;
    try
      FRequestCommandResult.Add(CommandId, 0);
    except
    end;
  finally
    FRequestCommandResultLock.Leave;
  end;
end;

procedure T1CAppServer.RemoveCommandResultList(CommandIdList: TJSONArray);
begin
  FCommandResultSaver.RemoveResultList(CommandIdList);
end;

procedure T1CAppServer.SaveSettings(const FileName: string);
var
  xmldoc: IXMLDocument;
begin
  try
    xmldoc:= CreateXMLDoc;
    xmldoc.AppendChild(xmldoc.CreateProcessingInstruction('xml',
      'version="1.0" encoding="utf-8" standalone="yes"'));  { TODO : точно utf-8?????? }
    xmldoc.DocumentElement:= xmldoc.CreateElement('Settings');

    SaveToXML(xmldoc.DocumentElement.AddChild('Server'));
    FProviders.Save(xmldoc.DocumentElement.AddChild('LocalProviders'));
    FNetProviders.Save(xmldoc.DocumentElement.AddChild('NetProviders'));

    FTasks.SaveToXML(xmldoc.DocumentElement.AddChild('Tasks'));

    if FileName = EmptyStr then
      if FSettingsFile <> EmptyStr then
        xmldoc.SaveToFile(FSettingsFile)
      else
        raise Exception.Create(sSRV_7)
    else
      xmldoc.SaveToFile(FileName);
  except
    on E: Exception do begin
      CodeSite.SendException(classname+'.SaveSettings', E);
      raise;
    end;
  end;
end;

procedure T1CAppServer.SaveToXML(ANode: IXMLNode);
var
  cld, node: IXMLElement;
begin
  cld:= ANode.AddChild('Log');
  cld.Attributes['Enable']:= IfThen(FLogEnabled, 'True', 'False' );
  cld.Attributes['Detailed']:= IfThen(FLogDetailed, 'True', 'False' );
  cld.Attributes['MaxSize']:= IntToSTr(FLogMaxSize);

  { TODO : Определить количество процессоров и *2 c пометкой default}
  if dsTCPServerTransport <> nil then
    ANode.AddChild('MaxThreads').Text:= IntToStr(dsTCPServerTransport.MaxThreads);

  case FConRunServerMode of
    TServerRunMode.srmNone: ANode.Attributes['Run']:= 'None';
    TServerRunMode.srmAppAutorun: ANode.Attributes['Run']:= 'UserAutorun';
    TServerRunMode.srmService: ANode.Attributes['Run']:= 'AsService';
    else
      Assert(False, 'Неизвестный тип запуска сервера');
  end;

  if Assigned(FOnRunModeChange) then
    try
      FOnRunModeChange(self, FConRunServerMode)
    except
    end;


  if FConPassword <> EmptyStr then
    ANode.AddChild('ConPassword').Text:= TPC1.Crypt(SERVER_CONFIG_CRYPT_KEY, FConPassword);

  if FSharedFolder <> EmptyStr then
    ANode.AddChild('SharedFolder').Text:= FSharedFolder;

  if FConCompressTraffic >= 0 then
    if FConCompressTraffic = SERVER_COMPRESS_TRAFFIC_DEFAULT then
      ANode.AddChild('CompressTraffic').Text:= inttostr(SERVER_COMPRESS_TRAFFIC_DEFAULT)
    else
      ANode.AddChild('CompressTraffic').Text:= 'True'
  else
    ANode.AddChild('CompressTraffic').Text:= 'False';

  if FConEncryptTrafficKey <> EmptyStr then
    ANode.AddChild('EncryptTrafficKey').Text:= TPC1.Crypt(SERVER_CONFIG_CRYPT_KEY, FConEncryptTrafficKey);


  cld:= ANode.AddChild('Interface');
  if dsTCPServerTransport <> nil then begin
    node:= cld.AddChild('TCP');
    node.Attributes['Port']:= IntToStr(dsTCPServerTransport.Port);
  end;
  if dsHTTPServerTransport <> nil then begin
    node:= cld.AddChild('HTTP');
    node.Attributes['Port']:= IntToStr(dsHTTPServerTransport.HttpPort);
  end;
  if dsWebModule <> nil then begin
    node:= cld.AddChild('REST');
    node.Attributes['Port']:= IntToStr(dsWebModule.HTTPServer.DefaultPort);
  end;


end;

procedure T1CAppServer.SendReceiptListToClient(Data: TObject;
  var RepeatInterval: Int64);
var
  receipt_list: TReceiptList;
  response: TJSONValue;
  answer_str: String;
  msg: TJSONArray;
begin
  receipt_list:= TReceiptList.Create;
  try
    FCommandResultSaver.FillReceiptList(TJSONString(Data).Value, receipt_list);
    if receipt_list.Count > 0 then begin
      response:= nil;
      try
        msg:= ServerInfoPack(siReceiptList, receipt_list.ToJSON);
        try
          msg.Owned:= False;
          dsServer.NotifyCallback(
            TJSONString(Data).Value,
            SERVER_CALLBACK_SERVER_INFO,
            msg,
            response,
            CLIENT_TIMEOUT
            );
        finally
          msg.Free;
        end;

        try
          answer_str:= response.Value;
        except
          answer_str:= EmptyStr;
        end;

      finally
        response.Free;
      end;

      if answer_str = CLIENT_RESPONSE_ON_CALLBACK then
        FCommandResultSaver.SetReceiptIsSent(receipt_list);
    end;
  finally
    receipt_list.Free;
  end;
end;

procedure T1CAppServer.SendCommandResultToClient(CommandResult: TCommandResult);
var
  response: TJSONValue;
  answer_str: String;
  msg: TJSONArray;
begin
  try
    response:= nil;
    try
      msg:= ServerInfoPack(siCommandResult, CommandResult.ToJSON);
      try
        msg.Owned:= False;
        dsServer.NotifyCallback(
          CommandResult.ClientId,
          SERVER_CALLBACK_SERVER_INFO,
          msg,
          response,
          CLIENT_TIMEOUT
          );

        try
          answer_str:= response.Value;
        except
          answer_str:= EmptyStr;
        end;

      finally
        msg.Free;
      end;

    finally
      response.Free;
    end;

    if answer_str <> CLIENT_RESPONSE_ON_CALLBACK then
      raise Exception.Create(sSRV_34);

  except
    CodeSite.Send(classname+'.SendCommandResultToClient', Exception(ExceptObject));
    raise;
  end;
end;

procedure T1CAppServer.SendPingToClient(Data: TObject;
  var RepeatInterval: Int64);
var
  response, msg: TJSONValue;
  answer_str: String;
  result: Boolean;
begin
  response:= nil;
  try
    msg:= TJSONString.Create(SERVER_PING_VALUE);
    msg.Owned:= False;
    try
      result:= dsServer.NotifyCallback(
        TDSCallbackTunnel(Data).ClientId,
        SERVER_CALLBACK_PING,
        msg,
        response,
        CLIENT_TIMEOUT
        );
    finally
      msg.Free;
    end;
    // если при вызове NotifyCallback происходит ошибка сокета, то DataSnap закрывает тунель сам, ничего специально делать не надо

    try
      answer_str:= response.Value;
    except
      answer_str:= EmptyStr;
    end;

  finally
    response.Free;
  end;

  if answer_str = CLIENT_RESPONSE_ON_CALLBACK then
    RepeatInterval:= SERVER_PING_INTERVAL
  else if result then // если ошибки не возникло, а ответ неверный, то придется закрыть тунель самим
    dsServer.UnregisterChannelCallback(TDSCallbackTunnel(Data));
end;

procedure T1CAppServer.SetAppAutorun(ARun: boolean);
const
  key = '\Software\Microsoft\Windows\CurrentVersion\Run';
var
  Reg: TRegIniFile;
begin
  Reg:= TRegIniFile.Create;
  try
    Reg.RootKey:= HKEY_LOCAL_MACHINE;
    Reg.CreateKey(Key);
    if Reg.OpenKey(Key, False) then
      if ARun then
        Reg.WriteString(key, SERVER_REGISTRY_NAME, ParamStr(0)+' /Autorun /OneInstance' )
      else
        Reg.DeleteValue(SERVER_REGISTRY_NAME);
  finally
    Reg.Free;
  end;
end;

procedure T1CAppServer.SetConCompressTraffic(const Value: integer);
var
  Filter: TCollectionItem;

  procedure ConfigureFilter(AFilter: TTransportFilterItem);
  begin
    if Value = 1024 then
      AFilter.Properties.Values['CompressMoreThan']:= '1024'
    else
      AFilter.Properties.Values['CompressMoreThan']:= '0';
  end;

begin
  if FConCompressTraffic <> Value then begin
    FConCompressTraffic:= Value;
    if Started then
      Stop();

    if dsTCPServerTransport <> nil then begin
      for Filter in dsTCPServerTransport.Filters do
        if (TTransportFilterItem(Filter).FilterId = 'ZLibCompression') then
          if (Value < 0) then begin // отключить компрессию
            dsTCPServerTransport.Filters.RemoveFilter(Filter.Index);
            Exit;
          end else begin
            ConfigureFilter(Filter as TTransportFilterItem);
            Exit;
          end;

      if Value>= 0 then begin
        Filter:= dsTCPServerTransport.Filters.GetItem(dsTCPServerTransport.Filters.AddFilter('ZLibCompression'));
        ConfigureFilter(Filter as TTransportFilterItem);
      end;

    end;
  end;
end;

procedure T1CAppServer.SetConEncryptRSA(const Value: boolean);
var
  Filter: TCollectionItem;

  procedure ConfigureFilter(AFilter: TTransportFilterItem);
  begin
    AFilter.Properties.Values['UseGlobalKey']:= 'True';
    AFilter.Properties.Values['KeyLength']:= '1024';
    AFilter.Properties.Values['KeyExponent']:= '3';
  end;

begin
  if FConEncryptRSA <> Value then begin
    FConEncryptRSA := Value;
    if Started then
      Stop();

    for Filter in dsTCPServerTransport.Filters do
      if (TTransportFilterItem(Filter).FilterId = 'RSA') then
        if not Value then begin
          dsTCPServerTransport.Filters.RemoveFilter(Filter.Index);
          Exit;
        end else begin
          ConfigureFilter(Filter as TTransportFilterItem);
          Exit;
        end;

    if Value then begin
      Filter:= dsTCPServerTransport.Filters.GetItem(dsTCPServerTransport.Filters.AddFilter('RSA'));
      ConfigureFilter(Filter as TTransportFilterItem);
    end;

  end;
end;

procedure T1CAppServer.SetConEncryptTrafficKey(const Value: string);

  procedure UpdateTransportFilter(Transport: TDSServerTransport);
  var
    Filter: TCollectionItem;
  begin
    for Filter in Transport.Filters do
      with Filter as TTransportFilterItem do
        if (FilterId = 'PC1') then
          if (Value = EmptyStr) then begin
            Transport.Filters.RemoveFilter( Index );
            Exit;
          end else begin
            Properties.Values['Key']:= Value;
            Exit;
          end;

    if Value <> EmptyStr then begin
      Filter:= Transport.Filters.GetItem(Transport.Filters.AddFilter('PC1'));
      TTransportFilterItem(Filter).Properties.Values['Key']:= Value;
    end;

  end;

begin
  if FConEncryptTrafficKey <> Value then begin
    FConEncryptTrafficKey := Value;

    if dsTCPServerTransport <> nil then
      UpdateTransportFilter(dsTCPServerTransport);
    if dsHTTPServerTransport <> nil then
      UpdateTransportFilter(dsHTTPServerTransport);

  end;
end;

procedure T1CAppServer.SetConRunServerMode(const Value: TServerRunMode);
begin
  if FConRunServerMode <> Value then begin
    FConRunServerMode := Value;
    case Value of
      TServerRunMode.srmNone: SetAppAutorun(False);
      TServerRunMode.srmAppAutorun: SetAppAutorun(True);
      TServerRunMode.srmService: SetAppAutorun(False);
      else
        Assert(False, 'Неизвестный режим запуска сервера');
    end;
  end;
end;

procedure T1CAppServer.SetDefaultLogParams;
var
  _AppRunFolder: string;

  function SetViewerPath(const ViewerName: string): string;
  begin
    result:= _AppRunFolder + ViewerName;

    if not FileExists(result) then
      if CodeSite.Installed then begin
        result:= IncludeTrailingPathDelimiter(CodeSiteGlobal.GetInstallPath())+'Bin\'+ViewerName;
        if not FileExists(result) then
          result:= EmptyStr
      end;
  end;

begin
  FLogEnabled:= false;
  FLogDetailed:= false;
  FLogMaxSize:= 1;

  _AppRunFolder:= IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)));

  FLogFileName:= _AppRunFolder + ChangeFileExt(ExtractFileName(ParamStr(0)), '');
  FLogDispatherFileName:= SetViewerPath(CodeSiteGlobal.strDispatcherExeName);

  FConRunServerMode:= TServerRunMode.srmNone;
  FSupportedInterface:= [];
  FConPassword:= EmptyStr;
  FMaxThread:= SERVER_MAX_SERVICE_THREAD;
  FSharedFolder:= EmptyStr;
  FConCompressTraffic:= -1;  // не сжимать
  FConEncryptTrafficKey:= EmptyStr;

  FLogFileViewerFileName:= SetViewerPath('CSFileViewer.exe');
end;

procedure T1CAppServer.SetLogDetailed(const Value: boolean);
begin
  FLogDetailed := Value;
{ TODO : ????? }
{  if Value then
    CodeSiteGlobal.TCSEventLogEntryType:= [TCSEventLogEntryType.etInfo..TCSEventLogEntryType.etError]
  else
    CodeSiteGlobal.TCSEventLogEntryType:= [TCSEventLogEntryType.
}
end;

procedure T1CAppServer.SetLogEnabled(const Value: boolean);
var
  DestLog: TCodeSiteDestination;
begin
  if (Value <> CodeSite.Enabled) or (FLogEnabled <> Value)  then begin
    FLogEnabled := Value;
    if not Value then begin
      if CodeSite.Enabled then
        CodeSite.CloseDispatcher();
      CodeSite.Enabled:= False;
    end else begin
      if not CodeSite.Installed then begin
        if FileExists(FLogDispatherFileName) then
          // запустим codesite в скрытом режиме
          ShellExecute(0, 'open', PChar(FLogDispatherFileName), PChar('-INIT_STEALTH'), nil, SW_MINIMIZE);
      end;

      DestLog:= TCodeSiteDestination.Create(CodeSite);
      try
        DestLog.LogFile.FilePath:= ExtractFilePath(FLogFileName);
        DestLog.LogFile.FileName:= ExtractFileName(FLogFileName);
        SetLogMaxSize(FLogMaxSize);

        DestLog.LogFile.Active:= True;
        DestLog.Viewer.Active:= False;
        CodeSite.Enabled:= True;

        CodeSite.Destination:= DestLog;
      except
        DestLog.Free;
        raise;
      end;
    end;
  end;
end;

procedure T1CAppServer.SetLogMaxSize(const Value: integer);
const
  MaxLogSize = 32;
var
  NewSizeKb: integer;
begin
  FLogMaxSize := Value;

  if CodeSite.Enabled then begin

    if Value <= MaxLogSize then
      NewSizeKb:= Value*1024
    else begin
      NewSizeKb:= MaxLogSize*1024;
      FLogMaxSize:= 32;
    end;

    if (CodeSite.Destination <> nil) then
      if CodeSite.Destination.LogFile <> nil then
        if Value <= 0 then begin
          CodeSite.Destination.LogFile.MaxParts:= 1;
          CodeSite.Destination.LogFile.MaxSize:= 0
        end else if CodeSite.Destination.LogFile.MaxSize <> NewSizeKb then begin
          CodeSite.Destination.LogFile.MaxParts:= 1;
          CodeSite.Destination.LogFile.MaxSize:= NewSizeKb;
        end;
  end;
end;

procedure T1CAppServer.SetPort(Protocol: TServerInterfaceItem; const Value: integer);
begin
  case Protocol of
    ssiTCP: begin
      if dsTCPServerTransport = nil then
        raise Exception.CreateFmt(sSRV_31, ['TCP']);
      if dsTCPServerTransport.Port <> Value then begin
        dsTCPServerTransport.Stop;
        dsTCPServerTransport.Port:= Value;
        dsTCPServerTransport.Start;
      end;
    end;
    ssiHTTP: begin
      if dsHTTPServerTransport = nil then
        raise Exception.CreateFmt(sSRV_31, ['HTTP']);
      if dsHTTPServerTransport.HttpPort <> Value then begin
        dsHTTPServerTransport.Stop;
        dsHTTPServerTransport.HttpPort:= Value;
        dsHTTPServerTransport.Start;
      end;
    end;
    ssiRest: begin
      if dsWebModule = nil then
        raise Exception.CreateFmt(sSRV_31, ['REST']);
      if dsWebModule.HTTPServer.DefaultPort <> Value then begin
        dsWebModule.HTTPServer.Active:= False;
        dsWebModule.HTTPServer.DefaultPort:= Value;
        dsWebModule.HTTPServer.Active:= True;
      end;
    end
    else
      Assert(False, 'Не известный интерфейс');
  end;
end;

procedure T1CAppServer.SetSharedFolder(const Value: string);
begin
  if trim(Value) <> EmptyStr then
    FSharedFolder:= IncludeTrailingPathDelimiter( Trim( Value ) )
  else
    FSharedFolder:= EmptyStr;
end;

procedure T1CAppServer.SetSupportedInterface(const Value: TServerInterfaces);
begin
  if FSupportedInterface <> Value then begin
    FSupportedInterface:= Value;

    if (dsTCPServerTransport = nil) and (ssiTCP in Value) then begin
      dsTCPServerTransport:= TDSTCPServerTransport.Create(nil);
      dsTCPServerTransport.AuthenticationManager:= dsAuthenticationManager;
      dsTCPServerTransport.Port:= SERVER_TCP_PORT;
      dsTCPServerTransport.MaxThreads:= FMaxThread;
      dsTCPServerTransport.Server:= dsServer;
    end else if (dsTCPServerTransport <> nil) and not (ssiTCP in Value)  then
      FreeAndNil(dsTCPServerTransport);

    if (dsHTTPServerTransport = nil) and (ssiHTTP in Value) then begin
      dsHTTPServerTransport:= TDSHTTPService.Create(nil);
      dsHTTPServerTransport.AuthenticationManager:= dsAuthenticationManager;
      dsHTTPServerTransport.HttpPort:= SERVER_HTTP_PORT;
      dsHTTPServerTransport.Server:= dsServer;
    end else if (dsHTTPServerTransport <> nil) and not (ssiHTTP in Value) then
      FreeAndNil(dsHTTPServerTransport);

    if (dsWebModule = nil) and (ssiRest in  Value) then begin
      dsWebModule:= TwvWebModule.CreateRT(nil, self);
      dsWebModule.HTTPServer.DefaultPort:= SERVER_REST_PORT;
      //dsWebModule.HTTPServer.KeepAlive
      //dsWebModule.HTTPServer.ServerSoftware:= SERVER_SERVICE_NAME;
      //dsWebModule.HTTPServer.MaxConnections:= FMaxThread;
      //dsWebModule.HTTPServer.Active:= True;
    end else if (dsWebModule <> nil) and not (ssiRest in  Value) then
      FreeAndNil(dsWebModule);

  end;
end;

procedure T1CAppServer.Start;
begin
  dsServer.Start;
  FTasks.Start;
end;

procedure T1CAppServer.Stop;
begin
  FTasks.Stop;
  dsServer.Stop;
end;

procedure T1CAppServer.StoreResult(AResult: TCommandResult);
begin
//---
exit;
//---
  FRequestCommandResultLock.Enter;
  try
    if FRequestCommandResult.ContainsKey(AResult.CommandId) then begin
      try
        SendCommandResultToClient(AResult);
        FRequestCommandResult.Remove(AResult.CommandId);
      finally
        AResult.Free;
      end;
    end else
      FCommandResultSaver.StoreResult(AResult);
  finally
    FRequestCommandResultLock.Leave;
  end;
end;

function T1CAppServer.NotifyCallback(ACmd: TCustom1CAction; Msg: TJSONValue): boolean;
var
  AResponse: TJSONValue;
begin
  AResponse:= nil;
  try
    result:= NotifyCallback(ACmd, Msg, AResponse);
  finally
    AResponse.Free;
  end;
end;

{ TLocalProviderList }

function TLocalProviderList.Find(PID: DWORD): TLocalProvider;
var
  P: TPair<TDBAlias, TCustomProvider>;
begin
  FCSList.Enter;
  try
    for p in self do
      if TLocalProvider(p.Value).ApplicationPID = PID then
        exit(TLocalProvider(p.Value));
    result:= nil;
  finally
    FCSList.Leave;
  end;
end;

function TLocalProviderList.CreateProvider(ProviderType: T1cProviderType;
  const DataBaseAlias: TDBAlias): TCustomProvider;
begin
  case ProviderType of
    pt1C77: result:= T1C77Provider.Create(self, ProviderType, DataBaseAlias);
    pt1C80..pt1C8x: result:= T1C8Provider.Create(self, ProviderType, DataBaseAlias);
    else begin
      result:= nil;
      Assert(False, 'Неизвестный тип провайдера');
    end;
  end;
end;

procedure TLocalProviderList.Delete(AItem: TCustomProvider);
begin
  TLocalProvider(AItem).FSyncCmdLock.Enter;
  inherited;
end;

function TLocalProviderList.Find(AProviderType: T1cProviderType; PID: DWORD): TLocalProvider;
var
  P: TPair<TDBAlias, TCustomProvider>;
begin
  FCSList.Enter;
  try
    for p in self do
      if (p.Value.ProviderType = AProviderType) and (TLocalProvider(p.Value).ApplicationPID = PID) then
        exit(TLocalProvider(p.Value));
    result:= nil;
  finally
    FCSList.Leave;
  end;
end;

function TLocalProviderList.Find(const DataBaseAlias: TDBAlias): TLocalProvider;
begin
  result:= inherited Find(DataBaseAlias) as TLocalProvider;
end;

{ T1cGuard }

constructor T1cGuard.Create(AServer: T1CAppServer);
begin
  inherited Create(true);
  FCS:= TCriticalSection.Create;
  FOpenQuery:= TList<TLocalProvider>.Create;
  FEvent:= TEvent.Create(nil, False, False, '');
  FreeOnTerminate:= False;
  FExistsPIDList:= TDictionary<DWORD, DWORD>.Create;
  FServer:= AServer;
end;

destructor T1cGuard.Destroy;
begin
  FCS.Free;
  FOpenQuery.Free;
  FEvent.Free;
  FExistsPIDList.Free;
  inherited;
end;

procedure T1cGuard.Do1CMonitoring;
var
  fname, fcompany: string;
  fversion: DWORD;
  Wnd: hWND;
  WndPID: DWord;
  SnapProc: DWORD;
  ProcEntry: TProcessEntry32;
  provider_type: T1cProviderType;
  find_prov: TLocalProvider;
  modal_win: TDictionary<hWnd, string>;
  buf: array [0..MAXCHAR] of Char;
  leave_possible: boolean;
  dlg_header: string;
  monitor_new_pid: boolean;
begin
  FCS.Enter;
  try
    try
      leave_possible:= false;
      monitor_new_pid:= FOpenQuery.Count > 0;
      modal_win:=TDictionary<hWnd, string>.Create;
      try
        while not leave_possible do begin
          leave_possible:= true;
          Wnd:=GetWindow(Application.Handle, gw_HWndFirst);
          while Wnd <> 0 do begin
            if (Wnd<>Application.Handle) then begin
              if IsWindow(Wnd) then begin
                GetWindowThreadProcessId(Wnd, @WndPID);

                if monitor_new_pid and not FExistsPIDList.ContainsKey(WndPID) then begin
                  // появился неизвестный нам процесс, определяем его принадлежность
                  SnapProc:= CreateToolhelp32Snapshot(TH32CS_SnapProcess, 0);
                  if SnapProc <> Invalid_Handle_Value then
                    try
                      ProcEntry.dwSize:= SizeOf(TProcessEntry32);
                      if Process32First(SnapProc, ProcEntry) then
                        repeat
                          if ProcEntry.th32ProcessID = WndPID then begin
                            fname:= ProcessFileName(ProcEntry.th32ProcessID);
                            GetFileVersion(fname, fversion, fcompany);
                            if (fcompany = NAME_OF_1C_COMPANY) then begin
                              // процесс принадлежит 1С необходимой нам версии
                              case fversion of
                                770: provider_type:= T1cProviderType.pt1C77;
                                800: provider_type:= T1cProviderType.pt1C80;
                                810: provider_type:= T1cProviderType.pt1C81;
                                820: provider_type:= T1cProviderType.pt1C82;
                                else
                                  provider_type:= T1cProviderType.pt1CNet; // аналогично Неизвестно
                              end;
                              // ищем провайдера с неопределенным (равным 0) ApplicationPID у которого
                              // версия 1С совпадает с найденным процессом
                              find_prov:= FindProviderInOpenQuery(provider_type);
                              if find_prov <> nil then
                                find_prov.ApplicationPID:= WndPID;
                            end;
                            // добавляем процесс в список обработанных
                            FExistsPIDList.Add(WndPID, 0);
                            break;
                          end;
                        until not Process32Next(SnapProc, ProcEntry);
                    finally
                      CloseHandle(SnapProc);
                    end;
                end;

                find_prov:= FServer.Providers.Find(WndPID);
                if (find_prov<>nil) and IsModal(Wnd) then begin
                  // в одной из наших 1с висит модальное окно
                  if modal_win.TryGetValue(Wnd, dlg_header) then begin
                    // это окно встречалось нам ранее,
                    // окно не закрылось заполняем соответствующее свойство
                    FInnerDLGFounded[ord(find_prov.ProviderType)]:= dlg_header;
                  end else begin
                    // запоминаем Wnd и заголовок окна
                    if GetWindowText(Wnd, buf, sizeof(buf))<>0 then
                      modal_win.Add(Wnd, PChar(@buf))
                    else
                      modal_win.Add(Wnd, sSRV_12);
                    leave_possible:= false; // пойдем на следующий проход цикла чтобы убедиться, что окно закрылось

                    //пытаемся закрыть окно
                    EmulateKey(Wnd, VK_RETURN);
                    SendMessage(Wnd, WM_CLOSE, 0, 0);
                  end;
                end;
              end;
            end;
            Wnd:=GetWindow(Wnd, gw_hWndNext);
            sleep(0);
          end;
          if not leave_possible then
            sleep(GUARD_WAIT_WHILE_MODAL_DIALOG_CLOSED);
        end;
      finally
        modal_win.Free;
      end;
    except
      on E: Exception do
        CodeSite.SendError(classname+'.Do1CMonitoring: '+sSRV_13+#10#13+E.Message);
    end;
  finally
    FCS.Leave;
  end;
end;


procedure T1cGuard.EmulateKey(Wnd: HWND; VKey: Integer);
begin
  PostMessage(Wnd, WM_KEYDOWN, VKey, 0);
  PostMessage(Wnd, WM_KEYUP, VKey, 0);
end;

function T1cGuard.GetInnerDLGFounded(Index: T1cProviderType): string;
begin
  result:= FInnerDLGFounded[ ord(Index) ];
end;

function T1cGuard.IsModal(Wnd: hWnd): boolean;
var
  style: cardinal;
//  buf: array [0..MAXCHAR] of Char;
begin
  result:= false;
  style:= GetWindowLong(Wnd, GWL_STYLE);

//  GetWindowText(Wnd, buf, sizeof(buf));

  if
    ((DS_MODALFRAME and style) = DS_MODALFRAME) and
//    ((DS_NOIDLEMSG and style) = DS_NOIDLEMSG) and
    not ((ws_disabled and style) = ws_disabled) then begin

    style:= GetWindowLong(Wnd, GWL_EXSTYLE);
    if (WS_EX_DLGMODALFRAME and style) = WS_EX_DLGMODALFRAME then
      Result := true;
  end;
end;

procedure T1cGuard.BuildExistsPIDList;
var
  Wnd: hWND;
  WndPID: DWord;
begin
  FExistsPIDList.Clear; { TODO : Временно }
  Wnd:= GetWindow(Application.Handle, gw_HWndFirst);
  while Wnd <> 0 do begin
    if (Wnd <> Application.Handle) then
      if IsWindow(Wnd) then begin
        GetWindowThreadProcessId(Wnd, @WndPID);
        if not FExistsPIDList.ContainsKey(WndPID) then
          FExistsPIDList.Add(WndPID, 0);
      end;
    Wnd:=GetWindow(Wnd, gw_hWndNext);
  end;
end;

procedure T1cGuard.Execute;
begin
  while not Terminated do begin

    if FOpenQuery.Count = 0 then
      FEvent.WaitFor( GUARD_RESCAN_TIMEOUT );

    if Terminated then break;

    try
      Do1CMonitoring();
    except
      on E: Exception do
        CodeSite.SendException('T1cGuard.Execute', E);
    end;
    Sleep(0);
  end;
end;

function T1cGuard.FindProviderInOpenQuery(AProvType: T1cProviderType): TLocalProvider;
var
  prv: TLocalProvider;
begin
  FCS.Enter;
  try
    for prv in FOpenQuery do
      if prv.ProviderType = AProvType then
        exit(prv);
    result:= nil
  finally
    FCS.Leave;
  end;
end;

function T1cGuard.StartConnectionMonitoring(Provider: TLocalProvider): boolean;
var
  prv: TLocalProvider;
begin
  FCS.Enter;
  try
    // проверяем, есть ли текущий выполяющийся запрос на открытие базы данных аналогичный требуемому
    // Если уже открывается такая же БД (тип 7.7/8.х + путь к базе данных), то отклоним запрос
    // Если выполняется открытие БД такого же типа как и требуемое, то отклоняем запрос
    // Т.о. одновременно можно открывать только по одной базе данных разного типа (7.7. и 8.х)
    for prv in FOpenQuery do
      if (prv.ProviderType=Provider.ProviderType) or (prv=Provider) or
      (prv.ConfDataBase=Provider.ConfDataBase) then
        raise Exception.Create(sSRV_1);

    if FOpenQuery.Count = 0 then
      BuildExistsPIDList;
    FOpenQuery.Add(Provider);

    if Suspended then
      Start;

    FEvent.SetEvent;

    result:= true;
  except
    on E: Exception do begin
      CodeSite.SendException(classname+'.StartMonitoring', E);
      result:=false;
    end;
  end;
  FCS.Leave;
end;

procedure T1cGuard.StopConnectionMonitoring(Provider: TLocalProvider);
begin
  FCS.Enter;
  try
    FOpenQuery.Extract( Provider );
    if FOpenQuery.Count = 0 then
      FExistsPIDList.Clear;
  finally
    FCS.Leave;
  end;
end;

procedure T1cGuard.Terminate;
begin
  inherited Terminate;
  if not Suspended then begin
    FEvent.SetEvent;
    while not Finished do
      Sleep(0);
  end;
end;

{ TLocalProvider }

function TLocalProvider.Acquire1CRef(const MethodName: string): OleVariant;
begin
  if not Connected then
    if not Connect() then
      raise Exception.CreateFmt(sSRV_3, [DataBaseAlias]);

  FSyncCmdLock.Enter;
  result:= RefTo;
  DoEvent(TProviderEventData.pdLocked);
end;

function TLocalProvider.CommandExecuteStatus(CommandId: T1CActionID): TCommandExecuteStatus;
begin
  result:= inherited CommandExecuteStatus(CommandId);
  if result = cesNotExist then
    if FProviderWorkThread.CommandExist(CommandId) then
      result:= cesWaitExecute;
end;

constructor TLocalProvider.Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType;
  const ADataBaseAlias: string);
begin
  inherited;
  FConfDataBase:= EmptyStr;
  FConfPassword:= EmptyStr;
  FConfUserName:= EmptyStr;
  F1CRef:= nil;
  FConfIsServerMode:= False;
  FApplicationPID:= 0;
  FCmdIncomeLock:= TCriticalSection.Create;
  FSyncCmdLock:= TCriticalSection.Create;
  FSharedVarName:= '';
  FLockRef:= 0;
  FProviderWorkThread:= TProviderWorkThread.Create(self);
  FProviderWorkThread.Start;
end;

destructor TLocalProvider.Destroy;
begin
  FProviderWorkThread.Terminate;
  FreeAndNil(FProviderWorkThread);

  Disconnect();

  FCmdIncomeLock.Free;
  FSyncCmdLock.Free;

  inherited;
end;

procedure TLocalProvider.Disconnect;
begin
  inherited;

  if F1CRef <> nil then begin
    SyncLock();
    try
//      F1CRef._Release;
      F1CRef:= nil;
    finally
      SyncUnLock();
      FApplicationPID:= 0;
      DoEvent(TProviderEventData.pdDisconnected);
    end;
  end;
end;

function TLocalProvider.Exec1CAction(ACmd: TCustom1CAction): integer;
begin
  FCmdIncomeLock.Enter;
  try
    if ACmd.StepStatus.WaitForExecute then begin
      ACmd.Prepare();
      Exec1CActionSync(ACmd);
//      exit( 0 );
      result:= 0;
    end else begin

      result:= FProviderWorkThread.Add(ACmd);
    end;
  finally
    FCmdIncomeLock.Leave;
  end;
end;

procedure TLocalProvider.Exec1CActionSync(ACmd: TCustom1CAction);
begin
  SyncLock();
  try
    if not Connected then
      Connect();

    if Connected then
      try
        SetCurrentAction(ACmd);
        ACmd.Execute( F1CRef );
      finally
        SetCurrentAction(nil);
      end
    else
      raise Exception.CreateFmt(sSRV_26, [ FDataBaseAlias ] );
  finally
    SyncUnlock();
  end;
end;

procedure TLocalProvider.ExecuteBatch(Code: TStringBuilder; IsCodeObjectOwner: boolean);
begin
  try
    ExecuteBatch(Code.ToString);
  finally
    if IsCodeObjectOwner then
      Code.Free;
  end;
end;

function TLocalProvider.GetActivated: boolean;
begin
  result:= F1CRef <> nil;
end;

function TLocalProvider.GetConnected: boolean;
begin
  result:= (F1CRef <> nil) and CheckConnection;
end;

function TLocalProvider.GetLocked: boolean;
begin
  if FCmdIncomeLock.TryEnter then begin
    FCmdIncomeLock.Leave;
    if FSyncCmdLock.TryEnter then begin
      FSyncCmdLock.Leave;
      exit(False);
    end;
  end;
  result:= True;
end;

procedure TLocalProvider.LoadFromXML(const ANode: IXMLNode);
var
  cld: IXMLNode;
begin
  inherited LoadFromXML(ANode);

  if ANode.HasAttribute('Database') then
    ConfDataBase:= ANode.Attributes['Database'];
  if ANode.HasAttribute('ServerMode') then
    if UpperCase(ANode.Attributes['ServerMode']) = 'TRUE' then begin
      ConfIsServerMode:= True;
      ConfSrvName:= ANode.Attributes['ServerName'];
    end;
  if ANode.HasAttribute('CUserName') then
    ConfUserName:= ANode.Attributes['CUserName'];
  if ANode.HasAttribute('CUserPassword') then
    ConfPassword:= TPC1.DeCrypt(SERVER_CONFIG_CRYPT_KEY, ANode.Attributes['CUserPassword']);

  cld:= ANode.ChildNodes.FindNode('SharedVar');
  if cld <> nil then
    SharedVarName:= cld.Text;

  DoEvent(TProviderEventData.pdReloadInfo);
end;

procedure TLocalProvider.Lock;
begin
  FCmdIncomeLock.Enter;
  FSyncCmdLock.Enter;
  inc(FLockRef);
  if FLockRef = 1 then
    DoEvent(TProviderEventData.pdLocked);
end;

procedure TLocalProvider.Realize1CRef(const MethodName: string);
begin
  FSyncCmdLock.Leave;
  DoEvent(TProviderEventData.pdUnlocked);
end;

function TLocalProvider.RefTo: OleVariant;
begin
  result:= F1CRef;
end;

procedure TLocalProvider.SaveToXML(const ANode: IXMLNode);
var
  chl: IXMLNode;
begin
  inherited SaveToXML(ANode);

  if ConfDataBase <> EmptyStr then
    ANode.Attributes['Database']:= ConfDataBase;
  if ConfIsServerMode then begin
    ANode.Attributes['ServerMode']:= 'True';
    ANode.Attributes['ServerName']:= ConfSrvName;
  end;
  if ConfUserName <> EmptyStr then
    ANode.Attributes['CUserName']:= ConfUserName;
  if ConfPassword <> EmptyStr then
    ANode.Attributes['CUserPassword']:= TPC1.Crypt(SERVER_CONFIG_CRYPT_KEY, ConfPassword);

  if SharedVarName <> EmptyStr then begin
    chl:= ANode.AddChild('SharedVar');
    chl.Text:= SharedVarName;
  end;
end;

procedure TLocalProvider.Set1CApplicationPID(APID: DWORD);
begin
  FApplicationPID:= APID;
end;

procedure TLocalProvider.SetConfDataBase(const Value: string);
begin
  FConfDataBase := trim(Value);
end;

procedure TLocalProvider.SetConfSrvName(const Value: string);
begin
  FConfSrvName := trim(Value);
end;

procedure TLocalProvider.SetConfUserName(const Value: string);
begin
  FConfUserName := trim(Value);
end;

procedure TLocalProvider.SetSharedVarName(const Value: string);
begin
  FSharedVarName := trim(Value);
end;

procedure TLocalProvider.SyncLock;
begin
  FSyncCmdLock.Enter;

  inc(FLockRef);
  if FLockRef = 1 then
    DoEvent(TProviderEventData.pdLocked);
end;

procedure TLocalProvider.SyncUnlock;
begin
  FSyncCmdLock.Leave;

  Dec(FLockRef);
  if FLockRef = 0 then
    DoEvent(TProviderEventData.pdLocked);
end;

procedure TLocalProvider.UnLock;
begin
  FSyncCmdLock.Leave;
  FCmdIncomeLock.Leave;

  Dec(FLockRef);
  if FLockRef = 0 then
    DoEvent(TProviderEventData.pdUnlocked);
end;

{ TCustomProvider }

function TCustomProvider.CommandExecuteStatus(CommandId: T1CActionID): TCommandExecuteStatus;
begin
  FSetActionLock.Enter;
  result:= TCommandExecuteStatus.cesNotExist;
  try
    try
      if FCurrentAction <> nil then
        if FCurrentAction.ClientInfo.CommandID = CommandId then
          exit(TCommandExecuteStatus.cesExecuting);
    except
      on E: Exception do
        CodeSite.SendException(classname+'.CommandExecuteStatus', E);
    end;
  finally
    FSetActionLock.Leave;
  end;
end;

constructor TCustomProvider.Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType;
  const ADataBaseAlias: TDBAlias);
begin
  FOwner:= AOwner;
  FProviderType:= AProviderType;
  FDataBaseAlias:= ADataBaseAlias;
  FCurrentAction:= nil;
  FPaused:= False;
  FSetActionLock:= TCriticalSection.Create;
  FAutoCloseInfo:= TAutoCloseProviderInfo.Create;
end;

destructor TCustomProvider.Destroy;
begin
  inherited;
  FSetActionLock.Free;
  FAutoCloseInfo.Free;
end;

procedure TCustomProvider.DoEvent(Event: TProviderEventData);
begin
  if Assigned(FOnChange) then
    try
      FOnChange(self, Event);
    except
      on E: Exception do
        CodeSite.SendException(classname+'.DoEvent', E);
    end;
end;

procedure TCustomProvider.SetConnected(const Value: boolean);
begin
  if Value then
    Connect()
  else
    Disconnect();
end;

procedure TCustomProvider.SetCurrentAction(ACmd: TCustom1CAction);
begin
  FSetActionLock.Enter;
  FCurrentAction:= ACmd;
  FSetActionLock.Leave;
end;

procedure TCustomProvider.SetDataBaseAlias(const Value: TDBAlias);
begin
  if FDataBaseAlias <> Value then
    FOwner.Update(self, Value);
  FDataBaseAlias:= Value;
end;

procedure TCustomProvider.SetPaused(const Value: boolean);
begin
  if FPaused <> Value then begin
    FPaused := Value;
    if Value then
      DoEvent(TProviderEventData.pdPaused)
    else
      DoEvent(TProviderEventData.pdResumed)
  end;
end;

procedure TCustomProvider.SetProviderType(const Value: T1cProviderType);
begin
  if FProviderType <> Value then
    if (FProviderType in [pt1C80..pt1C8x]) and (Value in [pt1C80..pt1C8x]) then begin
      if Connected then
        Disconnect;
      FProviderType:= Value
    end else
      Assert(False, 'Недопустимая смена типа провайдера');
end;

procedure TCustomProvider.LoadFromXML(const ANode: IXMLNode);
begin
  FAutoCloseInfo.LoadFromXML(ANode);
end;

procedure TCustomProvider.SaveToXML(const ANode: IXMLNode);
begin
  FAutoCloseInfo.SaveToXML(ANode);
end;

{ T1C77Provider }

function T1C77Provider.CheckConnection: boolean;
begin
  SyncLock();
  try
    RefTo.Метаданные.Документ; // возвращает количество документов в конфигурации
    result:= true;
  except
    on E: Exception do begin
      CodeSite.SendException(classname+'.CheckConnection', E);
      result:= false;
    end;
  end;
  SyncUnlock();
end;

function T1C77Provider.Connect: boolean;
var
  run_str: string;
begin
  try
    Disconnect;
  except
  end;

  run_str:=Format('/d"%s" /n"%s"',[ConfDataBase, ConfUserName]);
  if ConfPassword<>'' then
    run_str:=run_str+' /p"'+ConfPassword+'"';

  FOwner.Guard.StartConnectionMonitoring(self);

  try
    try
      TryConnect(run_str);
    except
      on E: Exception do begin
        FOwner.Guard.StopConnectionMonitoring(self);

        CodeSite.SendException(classname+'.Connect', E);

        if E is EOleSysError then begin
          FOwner.Guard.StopConnectionMonitoring(self);
          exit(False);
        end;

        CodeSite.SendFmtMsg(sSRV_14, [DataBaseAlias]);

        FOwner.Guard.StartConnectionMonitoring(self);

        try
          TryConnect(run_str+' /m', true);
          FOwner.Guard.StopConnectionMonitoring(self);
          CodeSite.SendFmtMsg(sSRV_24, [DataBaseAlias]);

          CodeSite.SendFmtMsg(sSRV_15, [DataBaseAlias]);

          FOwner.Guard.StartConnectionMonitoring(self);
          TryConnect(run_str);
          CodeSite.SendFmtMsg(sSRV_25, [DataBaseAlias]);
        except
          raise;
        end;
      end;
    end;

    if (FOwner.Guard.InnerDLGFounded[ProviderType] <> '') and (FOwner.Guard.InnerDLGFounded[ProviderType] <> 'Dialog') then { TODO : Тестовый вариант }
//    if FOwner.Guard.InnerDLGFounded[ProviderType] <> '' then
      // в 1с-ке висят модальные диалоговые окна, которые нельзя закрыть. Такая 1с нам не нужна.
      raise Exception.CreateFmt(sSRV_5, [DataBaseAlias, FOwner.Guard.InnerDLGFounded[ProviderType] ]);

    if not CheckConnection() then
      raise Exception.Create(Format(sSRV_3, [DataBaseAlias]));

    result:= true;
    DoEvent(TProviderEventData.pdConnected);
  except
    on E: Exception do begin
      try
        Disconnect();
      except
      end;
      result:= false;
      CodeSite.SendException(classname+'.Connect', E);
    end;
  end;

  FOwner.Guard.StopConnectionMonitoring(self);
end;

procedure T1C77Provider.TryConnect(const RunStr: string; AutoClose: boolean = false);
const
  RMTrade = 16440;
var
  r: integer;
begin
  { TODO : Реализация режима ConfIsServerMode }
  SyncLock();
  try
    Disconnect();

//http://www.tdoc.ru/c/programming/delphi/delphi-thread-model-page8.html
   if not ConfIsServerMode then
      F1CRef:= CreateOleObject(FAppKey)
    else
      F1CRef:= CreateOleObject('V77S.APPLICATION');

//   FSRunStr:= RunStr;
//   TThread.Synchronize(nil, CreateObj);

    if FAppRtm = 'TRADE' then
      r:= RefTo.Initialize(RMTrade, RunStr, 'NO_SPLASH_SHOW')
    else if FAppRtm = 'ACCOUNT' then
      r:= RefTo.Initialize(RefTo.rmAccount, RunStr, 'NO_SPLASH_SHOW')
    else if FAppRtm = 'CALC' then
      r:= RefTo.Initialize(RefTo.rmCalc, RunStr, 'NO_SPLASH_SHOW')
    else if FAppRtm = 'COMPLEX' then
      r:= RefTo.Initialize(RefTo.rmComplex, RunStr, 'NO_SPLASH_SHOW')
    else begin
      CodeSite.SendMsg('Неизвестный тип "'+FAppRtm+'". Соединение устанавливается с ключем "TRADE"');
      r:= RefTo.Initialize(RefTo.RMTrade, RunStr, 'NO_SPLASH_SHOW')
    end;

    if r <> -1 then begin
      Disconnect();
      raise Exception.Create(Format(sSRV_3, [DataBaseAlias]));
    end;
    if AutoClose then
      Disconnect()

  finally
    SyncUnlock();
  end;
end;

function T1C77Provider.EvalExpr(const Code: string): OleVariant;
begin
  inherited;

  SyncLock();
  try
    result:= RefTo.EvalExpr(Code);
    SyncUnlock();
  except
    on E: Exception do begin
      SyncUnlock();
      CodeSite.SendException(classname+'.EvalExpr', E);
      raise
    end;
  end;
end;

procedure T1C77Provider.ExecuteBatch(const Code: string);
begin
  inherited;

  SyncLock();
  try
    if RefTo.ExecuteBatch(Code) <> -1 then
      raise Exception.CreateFmt(sSRV_4, [Code]);
    SyncUnlock();
  except
    on E: Exception do begin
      SyncUnlock();
      CodeSite.SendException(classname+'.ExecuteBatch', E);
      raise Exception.CreateFmt(sSRV_4, [ LeftStr(E.Message, 1024) ]);
    end;
  end;
end;

constructor T1C77Provider.Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType;
  const ADataBaseAlias: string);
begin
  inherited;

end;

procedure T1C77Provider.SaveToXML(const ANode: IXMLNode);
begin
  inherited;
  if FAppKey <> DEF_APPKEY then
    ANode.Attributes['Class']:= FAppKey;
  if FAppRtm <> DRF_RTM then
    ANode.Attributes['RM']:= FAppRtm;
end;

procedure T1C77Provider.LoadFromXML(const ANode: IXMLNode);
begin
  inherited;
  if ANode.HasAttribute('Class') then
    FAppKey:= trim(AnsiUpperCase(ANode.Attributes['Class']))
  else
    FAppKey:= DEF_APPKEY;

  if ANode.HasAttribute('RM') then
    FAppRtm:= trim(AnsiUpperCase(ANode.Attributes['RM']))
  else
    FAppRtm:= DRF_RTM;
end;

procedure T1C77Provider.SetAppKey(const Value: string);
begin
  FAppKey := AnsiUpperCase(trim(Value));
end;

procedure T1C77Provider.SetAppRtm(const Value: string);
begin
  FAppRtm := AnsiUpperCase(trim(Value));
end;

{ TCustom1CAction }

procedure TCustom1CAction.CheckParams;
begin
  if Provider = nil then
    raise Exception.CreateFmt(sSRV_8, [FDBAliace]);
  if not FStepStatus.WaitForExecute then begin
    if (FClientInfo.ClientID = EmptyStr) then
      raise Exception.Create(sSRV_20);
    if (FClientInfo.ClientID = EmptyStr) then
      raise Exception.Create(sSRV_20);
  end;
end;

constructor TCustom1CAction.Create(AServer: T1CAppServer; const ADBAliase: TDBAlias);
begin
  FDBAliace:= ADBAliase;
  FServer:= AServer;
  FProvider:= FServer.Providers.Find(ADBAliase);

  FResultStatus:= T1CActionResult.Create;
  FSourceCode:= TStringBuilder.Create;
end;

constructor TCustom1CAction.CreateAsync(AServer: T1CAppServer; const ADBAliase: TDBAlias;
  const AClientID, ACommandID: string);
begin
  Create(AServer, ADBAliase);

  FStepStatus:= T1CActionStepStatus.Create(False);
  FClientInfo:= T1CActionClientInfo.Create(AClientID, SERVER_CALLBACK_COMMAND_NAME, ACommandID);
end;

constructor TCustom1CAction.CreateSync(AServer: T1CAppServer; const ADBAliase: TDBAlias;
  const AClientID, ACommandID: string);
begin
  Create(AServer, ADBAliase);

  FClientInfo:= T1CActionClientInfo.Create(AClientID, EmptyStr, ACommandID);
  FStepStatus:= T1CActionStepStatus.Create(True);
  FStepStatus.WaitForExecute:= True;
end;

destructor TCustom1CAction.Destroy;
begin
  if not FStepStatus.ExecDone then
    EndExec( T1CActionResult.Fail( sSRV_19 ) );
  if FResultStatus <> nil then
    FResultStatus.Free;
  FSourceCode.Free;
  inherited;
end;

procedure TCustom1CAction.EndExec(AResultStatus: T1CActionResult);
begin
  if (FResultStatus <> AResultStatus)  then
    FResultStatus.Free;
  FResultStatus:= AResultStatus;
  FStepStatus.ExecDone:= True;
  FStepStatus.Finished:= Now;

  // обработка асинхронного завершения операции
  if not FStepStatus.WaitForExecute then
    SendCallback;
end;

function TCustom1CAction.BeginExec(BuildWebAnswer: boolean): TJSONValue;
begin
  if FStepStatus.BeginExec then
    raise Exception.Create( sSRV_21 );
  FStepStatus.BeginExec:= True;

  FStepStatus.Started:= Now;
  FProvider.Exec1CAction( self );

  if FStepStatus.WaitForExecute then begin
    // ответ в асинхронном режиме будет передан в коллбеке
    FStepStatus.Finished:= Now;
    if not BuildWebAnswer then
      result:= FResultStatus.BuildAnswer()
    else
      result:= FResultStatus.BuildWebAnswer();
    // для асинхронного режима деструктор будет вызван в исполнительном потоке провайдера
    Free;
  end else
    result:= nil;
end;

procedure TCustom1CAction.Prepare;
begin
  if FStepStatus.Prepared then
    raise Exception.Create(sSRV_22);
  FStepStatus.Prepared:= True;
end;

procedure TCustom1CAction.SendCallback;
begin
  inherited;

  try
    FServer.NotifyCallback(self, FResultStatus.BuildAnswer(FClientInfo.CommandID));
  except
    on E: Exception do
      CodeSite.SendException(classname+'.SendCallback', E);
  end;
end;

{ TProviderWorkThread }

function TProviderWorkThread.Add(ACmd: TCustom1CAction): integer;
begin
  FCS.Enter;
  try
    FQueue.Enqueue( ACmd );
    result:= FQueue.Count;
    FEvent.SetEvent;
  finally
    FCS.Leave;
  end;
end;

procedure TProviderWorkThread.Clear;
var
  proc: TCustom1CAction;
begin
  FCS.Enter;
  try
    for proc in FQueue do begin
      proc.EndExec(T1CActionResult.Fail( sSRV_9 ) ) ;
    end;
    FQueue.Clear;
  finally
    FCS.Leave;
  end;
end;

function TProviderWorkThread.CommandExist(ACommandId: T1CActionID): boolean;
var
  C: TCustom1CAction;
begin
  FCS.Enter;
  try
    for c in FQueue do
      if c.ClientInfo.CommandID = ACommandId then
        exit(true);
    result:= False;
  finally
    FCS.Leave;
  end;
end;

constructor TProviderWorkThread.Create(Owner: TLocalProvider);
begin
  inherited Create(true);
  FreeOnTerminate:= False;
  FQueue:= TQueue<TCustom1CAction>.Create();
  FCS:= TCriticalSection.Create;
  FEvent:= TEvent.Create( nil, false, False, '');
  FOwner:= Owner;
end;

destructor TProviderWorkThread.Destroy;
begin
  Clear();
  FEvent.Free;
  FQueue.Free();
  FCS.Free;
  inherited;
end;

procedure TProviderWorkThread.Execute;
var
  Cmd: TCustom1CAction;
begin
  Cmd:= nil;
  CoInitializeEx(nil, COINIT_MULTITHREADED{COINIT_APARTMENTTHREADED});


  while not Terminated do begin
    FEvent.WaitFor(INFINITE);
    if Terminated then Break;

    FCS.Enter;
    try
      Cmd:= FQueue.Dequeue;
    except
      on E: Exception do begin
        CodeSite.SendException(classname+'.Execute:Queue.Dequeue', E);
        Cmd:= nil;
      end;
    end;
    FCS.Leave;

    if (Cmd <> nil) and not Terminated then begin
      try
        if not Cmd.StepStatus.Prepared then
          Cmd.Prepare();
        FOwner.Exec1CActionSync( Cmd );
      except
        on E: Exception do
          try
            Cmd.EndExec(T1CActionResult.Fail(E.Message) );
          except
            on E: Exception do
              CodeSite.SendException(classname+'.Execute:Cmd.EndExec', E);
          end;
      end;

      try
        Cmd.Free;
      except
        on E: Exception do
          CodeSite.SendException(classname+'.Execute:Cmd.Free', E);
      end;
    end else if (Cmd <> nil) then
      // нас завершают, вернем команду обратно в очередь
      try
        FQueue.Enqueue(cmd);
      except
      end;

  end;

  CoUninitialize();
end;

procedure TProviderWorkThread.Terminate;
begin
  inherited Terminate;
  FEvent.SetEvent;
  while not Finished do
    Sleep(0);
end;

{ T1C8Provider }

function T1C8Provider.CheckConnection: boolean;
var
  ConfName: string;
begin
  SyncLock();
  try
    ConfName:= RefTo.Metadata.Name;  // ConfName необходим. Получает результат и уничтожает выделенную строку при выходе из функции
    result:= True;
  except
    on E: Exception do begin
      CodeSite.SendException(classname+'.CheckConnection', E);
      result:= False;
    end;
  end;
  SyncUnlock();
end;

function T1C8Provider.Connect: boolean;
var
  run_str: string;
begin
  Disconnect;

  if ConfIsServerMode then
    run_str:= Format('Srvr="%s";Ref="%s";', [ConfSrvName, ConfDataBase])
  else
    run_str:= Format('File="%s";', [ConfDataBase]);
  { TODO : Реализовать режим авторизации пользователя операционной системой }
  run_str:= run_str + Format('Usr="%s";Pwd="%s"',[ConfUserName, ConfPassword]);

//  if not ConfIsServerMode then
//    FOwner.Guard.StartConnectionMonitoring(self);

  try
    TryConnect(run_str);

    if not CheckConnection() then
      raise Exception.Create(Format(sSRV_3, [DataBaseAlias]));

    result:= True;
    DoEvent(TProviderEventData.pdConnected);
  except
    on E: Exception do begin
      result:= False;
      Disconnect;
      CodeSite.SendException(classname+'.Connect', E);
    end;
  end;

//  if not ConfIsServerMode then
//    FOwner.Guard.StopConnectionMonitoring(self);
end;

constructor T1C8Provider.Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType;
  const ADataBaseAlias: string);
begin
  inherited;
  F1CConnector:= nil;
end;

procedure T1C8Provider.Disconnect;
begin
  if F1CConnector <> nil then begin
    SyncLock();
    try
      inherited;
    finally
      try
      //-grphcs.dll
        FreeAndNil(F1CConnector);
//        F1CConnector:= nil;
      finally
        SyncUnlock();
      end;
    end;
    DoEvent(TProviderEventData.pdDisconnected);
  end;
end;

function T1C8Provider.GetInstallInfo(LIBID: TGUID; AHiVer, ALowVer: integer): string;
var
  s: string;
  reg: TRegistry;
begin
  reg:= TRegistry.Create(KEY_READ);
  try
    reg.RootKey := HKEY_CLASSES_ROOT;
    s:= Format('TypeLib\%s\%d.%d\HELPDIR',[GUIDToString(LIBID), AHiVer, ALowVer]);
    if not reg.OpenKeyReadOnly(s) then begin
      CodeSite.SendError(Format(sSRV_50, ['HKEY_CLASSES_ROOT\'+s]));
      raise Exception.Create(sSRV_49);
    end;
    result:= IncludeTrailingPathDelimiter(reg.ReadString(EmptyStr) );
  finally
    reg.Free;
  end;
end;

function T1C8Provider.LoadModule(const AModuleName: string): OleVAriant;
begin
  SyncLock();
  try
    result := RefTo.ExternalDataProcessors.Create(AModuleName, 0);
  finally
    SyncUnlock();
  end;
end;

procedure T1C8Provider.TryConnect(const RunStr: string; AutoClose: boolean);

  procedure _Connect(AProviderType: T1cProviderType);
  var
    MS: TFilestream;
  begin
    case ProviderType of
      pt1C80: begin
        F1CConnector:= V80_TLB.TCOMConnector.Create(nil);
        F1CRef:= V81_TLB.TCOMConnector(F1CConnector).Connect1(RunStr);
      end;
      pt1C81: begin
        // Блокируем доступ при загрузке к grphcs.dll. Эта библиотека не требуется в режиме запуска 1с без интерфейса.
        // Если ее не блокировать, то после выгрузки 8.1 8.2 не сможет ее выгрузить и зависнет (т.к. библиотека уже выгружена)
        MS := TFilestream.Create(GetInstallInfo(LIBID_V81, V81MajorVersion, V81MinorVersion)+'grphcs.dll',
          fmOpenRead or fmShareExclusive );
        try
          F1CConnector:= V81_TLB.TCOMConnector.Create(nil);
          F1CRef:= V81_TLB.TCOMConnector(F1CConnector).Connect1(RunStr);
        finally
          MS.Free;
        end;
      end;
      pt1C82: begin
        F1CConnector:= V82_TLB.TCOMConnector.Create(nil);
        F1CRef:= V82_TLB.TCOMConnector(F1CConnector).Connect1(RunStr);
      end;
      else
        Assert(False, 'Версия 1С не поддерживается');
    end;

//    Module:= RefTo.ExternalDataProcessors.Create('c:\1.epf', 0);
//    Module.ПриОткрытииOLE(0);
//    if not RefTo.ПодключитьВнешнююКомпоненту('D:\Projects\Weaver\Source\wv1CAgent\Клиент\Win32\Debug\WeaverClient.dll','Client1C') then
//      CodeSite.SendMsg('not RefTo');

  end;

  function _GetInstalledPlatform(): T1cProviderType;
  var
    idsp: IDispatch;
  begin
    try
      idsp:= CreateOleObject('V82.COMConnector');
      exit(pt1C82);
    except
      on E: Exception do begin
        CodeSite.SendError(ClassName+'.TryConnect._GetInstalledPlatform: '+ E.Message);
        try
          idsp:= CreateOleObject('V81.COMConnector');
          exit(pt1C81);
        except
          on E: Exception do begin
            CodeSite.SendError(ClassName+'.TryConnect._GetInstalledPlatform: '+ E.Message);
            try
              idsp:= CreateOleObject('V80.COMConnector');
              exit(pt1C80);
            except
              on E: Exception do
                CodeSite.SendError(ClassName+'.TryConnect._GetInstalledPlatform: '+ E.Message);
            end;
          end;
        end;
      end;
    end;

    raise Exception.Create(sSRV_51);
  end;

begin
  Disconnect();

  try
    if ProviderType = pt1C8x then
      // определяем доступные интерфейсы
      // решение справедливо только для случая, когда на компьютере установлена единственная верся 1С
      ProviderType:= _GetInstalledPlatform();

    _Connect(ProviderType);
  except
    on E: Exception do
      raise Exception.Create(Format(sSRV_17, [DataBaseAlias, E.Message, ConfUserName]));
  end;

  SyncLock();
  try
    if F1CRef = nil then begin
      Disconnect();
      raise Exception.CreateFmt(sSRV_3, [DataBaseAlias]);
    end;

    if AutoClose then
      Disconnect();
  finally
    SyncUnlock();
  end;
end;


{ TCustomProviderList }

function TCustomProviderList.Add(ProviderType: T1cProviderType;
  const DataBaseAlias: TDBAlias): TCustomProvider;
var
  dba: TDBAlias;
begin
  FCSList.Enter;
  result:= nil;
  try
    dba:= GetAliasIdentificator(DataBaseAlias);
    if Find(dba) <> nil then
      raise Exception.CreateFmt(sSRV_2, [DataBaseAlias]);

    result:= CreateProvider(ProviderType, DataBaseAlias);
    inherited Add(dba, result);

    DoEvent(TProviderEventData.pdAdd, result);
  finally
    FCSList.Leave;
  end;
end;

procedure TCustomProviderList.Clear;
var
  P: TPair<TDBAlias, TCustomProvider>;
begin
  FCSList.Enter;
  try
    for p in self do
      try
        p.Value.Free();
      except
        on E: Exception do
          CodeSite.SendException(ClassName+'.Clear', E);
      end;
    inherited Clear();
  finally
    FCSList.Leave;
  end;
end;

function TCustomProviderList.CommandExecuteStatus(const ActionID: T1CActionID): TCommandExecuteStatus;
var
  Pair: TPair<TDBAlias, TCustomProvider>;
begin
  FCSList.Enter;
  try
    for Pair in Self do begin
      result:= Pair.Value.CommandExecuteStatus(ActionID);
      if result <> cesNotExist then
        exit;
    end;
    result:= cesNotExist;
  finally
    FCSList.Leave;
  end;
end;

constructor TCustomProviderList.Create;
begin
  inherited Create(1);
  FCSList:= TCriticalSection.Create;
  FGuard:= AGuard;
  FOnEvent:= nil;
end;

destructor TCustomProviderList.Destroy;
begin
  Clear();
  FCSList.Free;
  inherited;
end;

procedure TCustomProviderList.DoEvent(Event: TProviderEventData; Provider: TCustomProvider);
begin
  if Assigned(FOnEvent) then
    try
      FOnEvent(self, Provider, Event);
    except
      on E: Exception do
        CodeSite.SendException(classname+'.DoEvent', E);
    end;
end;

procedure TCustomProviderList.DoProviderEvent(Sender: TCustomProvider; Event: TProviderEventData);
begin
  DoEvent(Event, Sender);
end;

function TCustomProviderList.Exists(AItem: TCustomProvider): boolean;
begin
  FCSList.Enter;
  try
    result:= ContainsValue(AItem);
  finally
    FCSList.Leave;
  end;
end;

procedure TCustomProviderList.Delete(AItem: TCustomProvider);
begin
  FCSList.Enter;
  try
    AItem.Lock;
    Remove(GetAliasIdentificator(AItem.DataBaseAlias));

    DoEvent(TProviderEventData.pdDelete, AItem);

    AItem.Free;
  finally
    FCSList.Leave;
  end;
end;

procedure TCustomProviderList.FillArray(var Arr: TSupportedProvidersArr; AClearBefor: boolean);
var
  i, offset, prv_cnt: integer;
  List: TSupportedProvidersArr;
begin
  FCSList.Enter;
  try
    if AClearBefor then
      Arr:= ToArray()
    else begin
      { TODO : переделать на оптимальную реализацию копирования массива }
      List:= ToArray();
      prv_cnt:= Length(List);
      if prv_cnt > 0 then begin
        offset:= Length(Arr);
        SetLength(Arr, offset + prv_cnt);
        for i:= 0 to pred(prv_cnt) do
          Arr[offset+i]:= List[i];
      end;
    end;
  finally
    FCSList.Leave;
  end;
end;

function TCustomProviderList.Find(const DataBaseAlias: TDBAlias): TCustomProvider;
begin
  FCSList.Enter;
  try
    if not TryGetValue(GetAliasIdentificator(DataBaseAlias), result) then
      result:= nil;
  finally
    FCSList.Leave;
  end;
end;

function TCustomProviderList.GetAliasIdentificator(const DataBaseAlias: TDBAlias): TDBAlias;
begin
  result:= AnsiUpperCase(Trim(DataBaseAlias));
end;

procedure TCustomProviderList.Load(ProvidersNode: IXMLNode);
var
  xmlProvider: IXMLNode;
begin
  for xmlProvider in ProvidersNode.ChildNodes do
    if xmlProvider.NodeName = 'Provider' then
      Add(StrToProviderType(xmlProvider.Attributes['Type']),
        xmlProvider.Attributes['Alias']).LoadFromXML(xmlProvider);

  DoEvent(TProviderEventData.pdReloadAll, nil);
end;

procedure TCustomProviderList.Save(ProvidersNode: IXMLNode);
var
  Provider: TPair<TDBAlias, TCustomProvider>;
  xmlNode: IXMLNode;
begin
  FCSList.Enter;
  try
    for Provider in self do begin
      xmlNode:= ProvidersNode.AddChild('Provider');
      xmlNode.Attributes['Alias']:= Provider.Value.DataBaseAlias;
      xmlNode.Attributes['Type']:= ProviderTypeToStr(Provider.Value.ProviderType);
      Provider.Value.SaveToXML(xmlNode);
    end;
  finally
    FCSList.Leave;
  end;
end;

procedure TCustomProviderList.SetOnEvent(const Value: TProviderListEvent);
var
  Provider: TPair<TDBAlias, TCustomProvider>;
  EventHandlerProc: TProviderEvent;
begin
  FCSList.Enter;

  if not Assigned(Value) then
    EventHandlerProc:= nil
  else
    EventHandlerProc:= DoProviderEvent;

  try
    FOnEvent:= Value;

    for Provider in self do
      Provider.Value.OnChange:= EventHandlerProc;
  finally
    FCSList.Leave;
  end;
end;

procedure TCustomProviderList.Update(Provider: TCustomProvider; const Alias: TDBAlias);
var
  p: TCustomProvider;
begin
  Assert( ContainsValue(Provider), 'Провайдер не принадлежит списку');

  p:= Find(Alias);
  if (p <> nil) and (p <> Provider) then
    raise Exception.CreateFmt(sSRV_2, [Alias]);

  FCSList.Enter;
  try
    if ExtractPair(GetAliasIdentificator(Provider.DataBaseAlias)).Value = nil then
      raise Exception.CreateFmt(sSRV_36, [Provider.DataBaseAlias]);

    inherited add(GetAliasIdentificator(Alias), Provider);
  finally
    FCSList.Leave();
  end;

  DoEvent(TProviderEventData.pdReloadInfo, Provider);
end;

{ TNetProvider }

function TNetProvider.Connect: boolean;
begin
  try
    FClient.Connected:= True;
    result:= True;
    DoEvent(TProviderEventData.pdConnected);
  except
    on E: Exception do begin
      result:= False;
      CodeSite.SendException(classname+'.Connect', E);
    end;
  end;
end;

constructor TNetProvider.Create(AOwner: TCustomProviderList; AProviderType: T1cProviderType; const ADataBaseAlias: TDBAlias);
begin
  inherited;
  FClient:= T1CAppClient.Create;
  FRemoteDataAlias:= EmptyStr;
  FRemoteDataTypeInfo:= pt1CNet;
end;

destructor TNetProvider.Destroy;
begin
  FClient.Free;
  inherited;
end;

procedure TNetProvider.Disconnect;
begin
  FClient.Connected:= False;
  DoEvent(TProviderEventData.pdDisconnected);
end;

function TNetProvider.GetActivated: boolean;
begin
  result:= GetConnected;
end;

function TNetProvider.GetConnected: boolean;
begin
  result:= FClient.Connected;
end;

function TNetProvider.GetLocked: boolean;
begin
  result:= False;
end;

procedure TNetProvider.LoadFromXML(const ANode: IXMLNode);
var
  chl: IXMLNode;
begin
  inherited LoadFromXML(ANode);

  chl:= ANode.FindNode('RemouteData');
  if (chl <> nil) and chl.HasAttribute('Alias') then
    FRemoteDataAlias:= Trim(chl.Attributes['Alias'])
  else
    FRemoteDataAlias:= EmptyStr;

  if (chl <> nil) and chl.HasAttribute('TypeInfo') then
    FRemoteDataTypeInfo:= StrToProviderType( chl.Attributes['TypeInfo'] )
  else
    FRemoteDataTypeInfo:= pt1CNet;

  FClient.ConnectionParams:= T1CAppClientConnectionParams.Create(ANode);
  FClient.Proxy:= T1CAppClientProxyParams.Create(ANode);
  DoEvent(TProviderEventData.pdReloadInfo);
end;

procedure TNetProvider.Lock;
begin
end;

procedure TNetProvider.SaveToXML(const ANode: IXMLNode);
var
  chl: IXMLNode;
begin
  inherited SaveToXML(ANode);

  chl:= ANode.AddChild('RemouteData');
  chl.Attributes['Alias']:= FRemoteDataAlias;
  chl.Attributes['TypeInfo']:= ProviderTypeToStr(FRemoteDataTypeInfo);

  FClient.ConnectionParams.SaveToXML(ANode);
  FClient.Proxy.SaveToXML(ANode);
end;

procedure TNetProvider.UnLock;
begin
end;

{ TNetProviderList }

function TNetProviderList.CreateProvider(ProviderType: T1cProviderType;
  const DataBaseAlias: TDBAlias): TCustomProvider;
begin
  result:= TNetProvider.Create(self, ProviderType, DataBaseAlias);
end;

function TNetProviderList.Find(const DataBaseAlias: TDBAlias): TNetProvider;
begin
  result:= inherited Find(DataBaseAlias) as TNetProvider;
end;

{ TServerServiceContainer }

constructor TServerServiceContainer.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
  inherited;
  AllowPause:= False;
  DisplayName:= SERVER_SERVICE_NAME;
  Interactive:= True; //?????
  WaitHint:= SERVER_SERVICE_START_TIMEOUT;
  FServer:= T1CAppServer.Create();
end;

destructor TServerServiceContainer.Destroy;
begin
  FServer.Free;
  inherited;
end;

procedure TServerServiceContainer.DoStart;
begin
  inherited;
  FServer.Start();
end;

function TServerServiceContainer.DoStop: Boolean;
begin
  try
    FServer.Stop();
  finally
    result:= inherited;
  end;
end;

function TServerServiceContainer.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

{ TCommandResultSaverNew }

procedure TCommandResultSaver.CancelEvents(AResult: TCommandResult);
begin
  TEventHandler.CancelEvent(AResult, RemoveFromBufferEvent);
  if not AResult.Sync then
    TEventHandler.CancelEvent(AResult, StoreToDiskEvent);
end;

procedure TCommandResultSaver.ClearOldResults;
var
  query: TSQLQuery;
  boundary_time: TDateTime;
  i: Integer;
begin
  boundary_time:= IncMilliSecond(Now, -ResultLiveTime);
  System.TMonitor.Enter(FBuffer);
  try
    i:= 0;
    while i < FBuffer.Count do
      if CompareDateTime(FBuffer[i].Time, boundary_time) <= 0 then begin
        CancelEvents(FBuffer[i]);
        FBuffer.Delete(i);
      end else
        Inc(i);
  finally
    System.TMonitor.Exit(FBuffer);
  end;
  query:= TSQLQuery.Create(nil);
  try
    query.SQLConnection:= FSQLConnection;

    query.SQL.Text:= 'delete from CommandResults '+
      'where ResultTime < '+IntToStr(PInt64(@boundary_time)^);
    query.ExecSQL;
  finally
    query.Free;
  end;
end;

procedure TCommandResultSaver.ClearOldResultsEvent(Data: TObject;
  var RepeatInterval: Int64);
begin
  ClearOldResults;
  RepeatInterval:= ClearResultsInterval;
end;

procedure TCommandResultSaver.FillResultList(
  CommandIdList: TJSONArray; List: TCommandResultList);
const
  sql = 'select * from CommandResults where CommandId in (%s)';
var
  element: TJSONValue;
  command_result: TCommandResult;
  sql_arg: String;
  query: TSQLQuery;
begin
  System.TMonitor.Enter(FBuffer);
  try
    sql_arg:= EmptyStr;
    for element in CommandIdList do
      if FBufferIndex.TryGetValue(element.Value, command_result) then
        List.Add(command_result.GetRef<TCommandResult>)
      else
        sql_arg:= sql_arg + IfThen(sql_arg = EmptyStr, EmptyStr, ', ') + '"' + element.Value + '"';
    query:= TSQLQuery.Create(nil);
    try
      query.SQLConnection:= FSQLConnection;
      query.SQL.Text:= Format(sql, [sql_arg]);
      query.Open;
      while not query.Eof do begin
        List.Add(TCommandResult.Create(query));
        query.Next;
      end;
    finally
      query.Free;
    end;
  finally
    System.TMonitor.Exit(FBuffer);
  end;
end;

procedure TCommandResultSaver.FillReceiptList(const ClientId: String;
  List: TReceiptList);
const
  sql = 'select * from CommandResults where '+
        'not ReceiptIsSent and ClientId = "%s" and CommandId not in (%s)';
var
  command_result: TCommandResult;
  exclude_list: String;
  query: TSQLQuery;
begin
  System.TMonitor.Enter(FBuffer);
  try
    exclude_list:= EmptyStr;
    for command_result in FBuffer do
      if (not command_result.Sync) and (not command_result.ReceiptIsSent) and (command_result.ClientId = ClientId) then begin
        if command_result.StoredToDisk then
          exclude_list:= exclude_list + IfThen(exclude_list = EmptyStr, EmptyStr, ', ') + '"' + command_result.CommandId + '"';
        List.Add(TReceipt.Create(command_result));
      end;
    query:= TSQLQuery.Create(nil);
    try
      query.SQLConnection:= FSQLConnection;
      query.SQL.Text:= Format(sql, [ClientId, exclude_list]);
      query.Open;
      while not query.Eof do begin
        if not FBufferIndex.ContainsKey(query['CommandId']) then
          List.Add(TReceipt.Create(query));
        query.Next;
      end;
    finally
      query.Free;
    end;
  finally
    System.TMonitor.Exit(FBuffer);
  end;
end;

constructor TCommandResultSaver.Create(ASQLConnection: TSQLConnection);
begin
  FSQLConnection:= ASQLConnection;
  FResultLiveTime:= SERVER_COMMAND_RESULT_LIVETIME;
  FClearResultsInterval:= SERVER_COMMAND_RESULT_CLEAR_INTERVAL;
  FResultBufferLiveTime:= SERVER_COMMAND_RESULT_BUFFER_LIVETIME;
  FResultStoreToDiskTime:= SERVER_COMMAND_RESULT_STORE_TO_DISK_TIME;
  FBuffer:= TObjectList<TCommandResult>.Create(True);
  FBufferIndex:= TDictionary<String, TCommandResult>.Create;
  FBufferSyncCommands:= TDictionary<String, TCommandResult>.Create;
  FBuffer.OnNotify:= OnChangeBuffer;
  ClearOldResults;
  TEventHandler.AddEvent(Self, nil, nil, ClearOldResultsEvent, ClearResultsInterval);
end;

destructor TCommandResultSaver.Destroy;
begin
  TEventHandler.CancelGroupEvents(Self);
  StoreBuffer;
  FBuffer.Free;
  FBufferIndex.Free;
  FBufferSyncCommands.Free;
  inherited;
end;

procedure TCommandResultSaver.OnChangeBuffer(Sender: TObject;
  const Item: TCommandResult; Action: TCollectionNotification);
var
  result: TCommandResult;
begin
  case Action of
    cnAdded: begin
      FBufferIndex.Add(Item.CommandId, Item);
      if Item.Sync then begin
        if FBufferSyncCommands.TryGetValue(Item.ClientId, result) then
          FBuffer.Remove(result);
        FBufferSyncCommands.Add(Item.ClientId, Item);
      end;
    end;
    cnRemoved, cnExtracted: begin
      FBufferIndex.Remove(Item.CommandId);
      FBufferSyncCommands.Remove(Item.ClientId);
    end;
  end;
end;

procedure TCommandResultSaver.RemoveResult(const CommandId: String);
var
  list: TJSONArray;
begin
  list:= TJSONArray.Create;
  try
    list.AddElement(TJSONString.Create(CommandId));
    RemoveResultList(list);
  finally
    list.Free;
  end;
end;

procedure TCommandResultSaver.RemoveResultList(
  CommandIdList: TJSONArray);
const
  sql = 'delete from CommandResults where CommandId in (%s)';
var
  command_result: TCommandResult;
  id_list, command_id: String;
  element: TJSONValue;
begin
  try
    System.TMonitor.Enter(FBuffer);
    try
      id_list:= EmptyStr;
      for element in CommandIdList do begin
        command_id:= EmptyStr;
        if FBufferIndex.TryGetValue(element.Value, command_result) then begin
          if command_result.StoredToDisk then
            command_id:= command_result.CommandId;
          CancelEvents(command_result);
          FBuffer.Remove(command_result);
        end else
          command_id:= element.Value;
        if command_id <> EmptyStr then
          id_list:= id_list + IfThen(id_list = EmptyStr, EmptyStr, ', ') + '"' + command_id+ '"';
      end;
      if id_list <> EmptyStr then
        FSQLConnection.Execute(Format(sql, [id_list]), nil);
    finally
      System.TMonitor.Exit(FBuffer);
    end;
  except
    CodeSite.SendException(classname+'.RemoveCommandResultList', Exception(ExceptObject));
  end;
end;

procedure TCommandResultSaver.RemoveFromBufferEvent(AResult: TObject; var RepeatInterval: Int64);
begin
  System.TMonitor.Enter(FBuffer);
  try
    if not FBuffer.Contains(TCommandResult(AResult)) then exit;
    TEventHandler.CancelEvent(AResult, StoreToDiskEvent);
    if not TCommandResult(AResult).StoredToDisk then
      if StoreToDisk(TCommandResult(AResult)) then
        FBuffer.Remove(TCommandResult(AResult))
      else
        RepeatInterval:= FResultBufferLiveTime;
  finally
    System.TMonitor.Exit(FBuffer);
  end;
end;

function TCommandResultSaver.GetResult(const CommandId: String; DiskLook: Boolean): TCommandResult;
const
  sql = 'select * from CommandResults where CommandId = "%s"';
var
  query: TSQLQuery;
begin
  System.TMonitor.Enter(FBuffer);
  try
    if FBufferIndex.TryGetValue(CommandId, result) then
      exit(result.GetRef<TCommandResult>);
    if not DiskLook then
      exit(nil);
    query:= TSQLQuery.Create(nil);
    try
      query.SQLConnection:= FSQLConnection;
      query.SQL.Text:= Format(sql, [CommandId]);
      query.Open;
      if not query.Eof then
        exit(TCommandResult.Create(query));
    finally
      query.Free;
    end;
  finally
    System.TMonitor.Exit(FBuffer);
  end;
  result:= nil;
end;

procedure TCommandResultSaver.StoreResult(AResult: TCommandResult);
begin
  RemoveResult(AResult.CommandId);
  System.TMonitor.Enter(FBuffer);
  try
    FBuffer.Add(AResult);
  finally
    System.TMonitor.Exit(FBuffer);
  end;
  if not AResult.Sync then
    TEventHandler.AddEvent(Self, nil, AResult, StoreToDiskEvent, FResultStoreToDiskTime);
  TEventHandler.AddEvent(Self, nil, AResult, RemoveFromBufferEvent, FResultBufferLiveTime);
end;

procedure TCommandResultSaver.SetReceiptIsSent(List: TReceiptList);
const
  sql = 'update CommandResults set ReceiptIsSent = 1 where CommandId in (%s)';
var
  command_result: TCommandResult;
  receipt: TReceipt;
  sql_arg, command_id: String;
begin
  System.TMonitor.Enter(FBuffer);
  try
    sql_arg:= EmptyStr;
    for receipt in List do begin
      command_id:= EmptyStr;
      if FBufferIndex.TryGetValue(receipt.CommandId, command_result) then begin
        command_result.ReceiptIsSent:= True;
        if command_result.StoredToDisk then
          command_id:= command_result.CommandId;
      end else
        command_id:= receipt.CommandId;
      if command_id <> EmptyStr then
        sql_arg:= sql_arg + IfThen(sql_arg = EmptyStr, EmptyStr, ', ') + '"' + command_id + '"';
    end;
    FSQLConnection.Execute(Format(sql, [sql_arg]), nil);
  finally
    System.TMonitor.Exit(FBuffer);
  end;
end;

procedure TCommandResultSaver.StoreBuffer;
var
  result: TCommandResult;
begin
  for result in FBuffer do
    StoreToDisk(result);
end;

function TCommandResultSaver.StoreToDisk(AResult: TCommandResult): Boolean;
const
  sql = 'insert into CommandResults(%s, %s, %s, %s, %s, %s, %s, %s) '+
        'values(:%0:s, :%s, :%s, :%s, :%s, :%s, :%s, :%s)';
  cClientId = 'ClientId';
  cResultTime = 'ResultTime';
  cStarted = 'Started';
  cFinished = 'Finished';
  cCommandId = 'CommandId';
  cResult = 'Result';
  cErrorDescription = 'ErrorDescription';
  cReceiptIsSent = 'ReceiptIsSent';
var
  params: TParams;
  buf: TArray<Byte>;
begin
  if AResult.StoredToDisk or AResult.Sync then
    exit(True);
  try
    params:= TParams.Create;
    try
      params.CreateParam(ftString, cClientId, ptInput);
      params.CreateParam(ftLargeint, cResultTime, ptInput);
      params.CreateParam(ftLargeint, cStarted, ptInput);
      params.CreateParam(ftLargeint, cFinished, ptInput);
      params.CreateParam(ftString, cCommandId, ptInput);
      params.CreateParam(ftBlob, cResult, ptInput);
      params.CreateParam(ftString, cErrorDescription, ptInput);
      params.CreateParam(ftBoolean, cReceiptIsSent, ptInput);

      params.ParamByName(cClientId).AsString:= AResult.ClientId;
      params.ParamByName(cResultTime).AsLargeInt:= PInt64(@AResult.Time)^;
      params.ParamByName(cStarted).AsLargeInt:= PInt64(@AResult.Started)^;
      params.ParamByName(cFinished).AsLargeInt:= PInt64(@AResult.Finished)^;
      params.ParamByName(cCommandId).AsString:= AResult.CommandId;

      SetLength(buf, AResult.Value.EstimatedByteSize);
      AResult.Value.ToBytes(buf, 0);
      params.ParamByName(cResult).AsBlob:= buf;

      params.ParamByName(cErrorDescription).AsString:= AResult.ErrorDescription;
      params.ParamByName(cReceiptIsSent).AsBoolean:= AResult.ReceiptIsSent;

      FSQLConnection.Execute(Format(sql, [cClientId, cResultTime, cStarted, cFinished, cCommandId, cResult, cErrorDescription, cReceiptIsSent]), params);

      AResult.StoredToDisk:= True;
    finally
      params.Free;
    end;
  except
    CodeSite.SendException(classname+'.StoreToDisk', Exception(ExceptObject));
  end;
  result:= AResult.StoredToDisk;
end;

procedure TCommandResultSaver.StoreToDiskEvent(AResult: TObject; var RepeatInterval: Int64);
begin
  System.TMonitor.Enter(FBuffer);
  try
    if not FBuffer.Contains(TCommandResult(AResult)) then exit;
    if not StoreToDisk(TCommandResult(AResult)) then
      RepeatInterval:= FResultStoreToDiskTime;
  finally
    System.TMonitor.Exit(FBuffer);
  end;
end;

{ TAutoCloseProviderInfo }

constructor TAutoCloseProviderInfo.Create;
begin
  Clear();
  FAutoCloseInfoList.Add(self);
end;

destructor TAutoCloseProviderInfo.Destroy;
begin
  Clear();
  FAutoCloseInfoList.Extract(self);
  CheckMinInterval();
  inherited;
end;

procedure TAutoCloseProviderInfo.LoadFromXML(const ANode: IXMLNode);
var
  i, N: integer;
  FS: TFormatSettings;
  RNode, CNode, SCNode: IXMLNode;

  function StrToWeekDay(const Val: string): integer;
  var
    Str: string;
  begin
    Str:= AnsiLowerCase(trim(Val));
    if Str =  'mon' then
      result:= 0
    else if Str = 'tue' then
      result:= 1
    else if Str = 'wed' then
      result:= 2
    else if Str = 'thu' then
      result:= 3
    else if Str = 'fri' then
      result:= 4
    else if Str = 'sat' then
      result:= 5
    else if Str = 'sun' then
      result:= 6
    else
      raise Exception.CreateFmt('Неизвестное значение "%s"', [Val]);
  end;

  procedure FillTimeFormat();
  begin
    FS:= TFormatSettings.Create;
    FS.TimeSeparator:= ':';
    FS.ShortTimeFormat:= 'hh:mm:ss';
    FS.LongTimeFormat:= FS.ShortTimeFormat;
  end;

begin
  Clear();

  RNode:= ANode.ChildNodes.FindNode('AutoClose');
  if RNode = nil then
    exit;

  CNode:= RNode.FindNode('Inactive');
  if CNode <> nil then
    if not CNode.HasAttribute('Dim') then
      CodeSite.SendError('Недопустимый формат параметра "Inactive:Inactive"' )
    else begin
      FInactiveTiks.Tiks:= StrToInt64Def(CNode.Text, 0);
      if FInactiveTiks.Tiks <= 0 then
        CodeSite.SendError('Недопустимое значение параметра "AutoClose:Inactive"')
      else begin
        try
          FInactiveTiks.TypeFromStr(CNode.Attributes['Dim']);
        except
          on E: Exception do begin
            CodeSite.SendError('Недопустимое значение типа в параметре "AutoClose:Inactive"');
            FInactiveTiks.Tiks:= 0;
          end;
        end;
      end;
    end;

  CNode:= RNode.FindNode('Time');
  if CNode <> nil then
    if not CNode.HasAttribute('Value') then
      CodeSite.SendError('Недопустимый формат параметра "AutoClose:Time"' )
    else begin
      FillTimeFormat();

      FCloseOnTime:= StrToTimeDef( CNode.Text,  0, FS );
      if FCloseOnTime <= 0 then
        CodeSite.SendError('Недопустимое значение параметра "AutoClose:Time"')
    end
  else begin
    CNode:= RNode.FindNode('WeekTime');
    if CNode <> nil then begin
      FillTimeFormat();

      if CNode.HasAttribute('On') then
        FCloseOnWeekDayTimeEnable:= AnsiUpperCase(CNode.Attributes['On']) = 'TRUE'
      else
        FCloseOnWeekDayTimeEnable:= False;
      for i:= 0 to CNode.ChildNodes.Count-1 do begin
        SCNode:= CNode.ChildNodes[i];
        try
          N:= StrToWeekDay(SCNode.NodeName);
          FCloseOnWeekDayTime[N]:= StrToTime( SCNode.Text, FS );
        except
          on E: Exception do
            CodeSite.SendWarning('Отдельное Значение "AutoClose:WeekTime" игнорировано', [E.Message]);
        end;
      end;

    end else
      FCloseOnWeekDayTimeEnable:= False;
  end;

end;

procedure TAutoCloseProviderInfo.SaveToXML(const ANode: IXMLNode);
var
  i, k: integer;
  RNode, CNode, SCNode: IXMLNode;
  FS: TFormatSettings;

  function IndexToWeekDay(AIndex: Integer): string;   // обратное преобразование выше  StrToWeekDay
  begin
    case AIndex of
      0: result:= 'Mon';
      1: result:= 'Tue';
      2: result:= 'Wed';
      3: result:= 'Thu';
      4: result:= 'Fri';
      5: result:= 'Sat';
      6: result:= 'Sun';
      else
        Assert(false, Format('Неизвестный тип %d', [AIndex]));
    end;
  end;

  procedure FillTimeFormat();
  begin
    FS:= TFormatSettings.Create;
    FS.TimeSeparator:= ':';
    FS.ShortTimeFormat:= 'hh:mm:ss';
    FS.LongTimeFormat:= FS.ShortTimeFormat;
  end;


begin
  if IsEmpty then begin
    RNode:= ANode.FindNode('AutoClose');
    if RNode <> nil then
      ANode.ChildNodes.Remove(RNode);
    Exit;
  end;

  RNode:= ANode.AddChild('AutoClose');

  if FInactiveTiks.Tiks > 0 then begin
    CNode:= RNode.AddChild('Inactive');
    CNode.Attributes['Dim']:= FInactiveTiks.TypeToStr();
    CNode.Text:= IntToStr(FInactiveTiks.Tiks);
  end;

  if FCloseOnTime > 0 then begin
    FillTimeFormat();

    CNode:= RNode.AddChild('Time');
    CNode.Text:= TimeToStr(FCloseOnTime, FS);
  end else begin
    for i:= 0 to 6 do
      if FCloseOnWeekDayTime[i] > 0 then begin
        FillTimeFormat();

        CNode:= RNode.AddChild('WeekTime');
        if FCloseOnWeekDayTimeEnable then
          CNode.Attributes['On']:= 'True'
        else
          CNode.Attributes['On']:= 'False';
        for k:= i to 6 do
          if FCloseOnWeekDayTime[k] > 0 then begin
            SCNode:= CNode.AddChild(IndexToWeekDay(k));
            SCNode.Text:= TimeToStr(FCloseOnWeekDayTime[k], FS);
          end;

        break;
      end;
  end;
end;

procedure TAutoCloseProviderInfo.Clear;
var
  i: integer;
begin
  FInactiveTiks:= TInactiveTiks.Create(0, ms);
  FCloseOnTime:= 0;
  FCloseOnWeekDayTimeEnable:= False;
  for i:=0 to Length(FCloseOnWeekDayTime)-1 do
    FCloseOnWeekDayTime[i]:= 0;
end;

function TAutoCloseProviderInfo.GetIsEmpty: boolean;
var
  i: integer;
begin
  if FInactiveTiks.Tiks > 0 then
    exit(False);
  if FCloseOnTime > 0 then
    exit(False);

  for i:=0 to 6 do
    if FCloseOnWeekDayTime[i] > 0 then
      exit(False);

  result:= True;
end;

procedure TAutoCloseProviderInfo.CheckMinInterval;
var
  Info: TAutoCloseProviderInfo;
begin
  for Info in FAutoCloseInfoList do
    if Info.InactiveTiks.IsLess(MinInactiveTimeInterval) then
      MinInactiveTimeInterval:= Info.InactiveTiks;
end;

procedure TAutoCloseProviderInfo.SetInactiveTiks(const Value: TInactiveTiks);
begin
  if not FInactiveTiks.IsSame(Value) then begin
    FInactiveTiks:= Value;
    CheckMinInterval();
  end;
end;

{ TAutoCloseProviderInfo.TInactiveTimeInterval }

constructor TAutoCloseProviderInfo.TInactiveTiks.Create(ATime: int64;
  ATimeType: TInactiveTimeType);
begin
  self.Tiks:= ATime;
  self.TimeType:= ATimeType;
end;

function TAutoCloseProviderInfo.TInactiveTiks.IsSame(Value: TInactiveTiks): boolean;
begin
  result:= (Self.Tiks = Value.Tiks) and (Self.TimeType = Value.TimeType)
end;

function TAutoCloseProviderInfo.TInactiveTiks.IsLess(Value: TInactiveTiks): boolean;
begin
  if Value.Tiks = 0 then
    exit(False);

  if ord(Value.TimeType) < ord(self.TimeType) then
    exit(True);
  result:= Value.Tiks < self.Tiks;
end;

function TAutoCloseProviderInfo.TInactiveTiks.TypeToStr: string;
begin
  case TimeType of
    ms: result:= 'ms';
    seconds: result:= 's';
    minuts: result:= 'm';
    hours: result:= 'h';
    days: result:= 'd';
    else
      Assert(false, 'Неизвестный тип');
  end;
end;

procedure TAutoCloseProviderInfo.TInactiveTiks.TypeFromStr(const AType: string);
var
  s: string;
begin
  s:= trim(AnsiLowerCase(AType));
  if s = 'ms' then
    Self.TimeType:= TInactiveTimeType.ms
  else if s = 's' then
    Self.TimeType:= TInactiveTimeType.seconds
  else if s = 'm' then
    Self.TimeType:= TInactiveTimeType.minuts
  else if s = 'h' then
    Self.TimeType:= TInactiveTimeType.hours
  else if s = 'd' then
    Self.TimeType:= TInactiveTimeType.days
  else
    raise Exception.Create(Format('Неизвестный тип значения "%s"', [AType]));
end;

function TAutoCloseProviderInfo.GetCloseOnWeekDayTime(DayOfWeek: byte): TDateTime;
begin
  result:= FCloseOnWeekDayTime[DayOfWeek];
end;

procedure TAutoCloseProviderInfo.SetCloseOnWeekDayTime(DayOfWeek: byte; const Value: TDateTime);
begin
  FCloseOnWeekDayTime[DayOfWeek]:= Value;
end;

function TAutoCloseProviderInfo.GetIsWeekTimeEmpty: boolean;
var
  i: integer;
begin
  for i:=0 to 6 do
    if FCloseOnWeekDayTime[i] > 0 then
      exit(False);
  result:= True;
end;

initialization
begin
  TAutoCloseProviderInfo.MinInactiveTimeInterval:= TAutoCloseProviderInfo.TInactiveTiks.Create(0, ms);
  TAutoCloseProviderInfo.FAutoCloseInfoList:= TObjectList<TAutoCloseProviderInfo>.Create(False);
end;

finalization
begin
  TAutoCloseProviderInfo.FAutoCloseInfoList.Free;
end;

end.

